1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Store.AssetSegment
    3   ( assetSegmentTag
    4   , getAssetSegmentStore
    5   ) where
    6 
    7 import Control.Monad (unless, liftM2, when)
    8 import Control.Monad.IO.Class (liftIO)
    9 import Control.Monad.Trans.Resource (InternalState)
   10 import qualified Data.ByteString as BS
   11 import qualified Data.ByteString.Char8 as BSC
   12 import Data.ByteString.Lazy.Internal (defaultChunkSize)
   13 import Data.Fixed (showFixed, Milli)
   14 import Data.Maybe (isJust, fromMaybe, fromJust)
   15 import Data.Monoid ((<>))
   16 import Data.Word (Word16)
   17 import qualified Data.Streaming.Process as P
   18 import qualified Database.PostgreSQL.Typed.Range as Range
   19 import System.IO (Handle, hClose)
   20 import System.Posix.FilePath (takeDirectory)
   21 import System.Posix.Files.ByteString (setFileMode, fileExist)
   22 
   23 import Databrary.Ops
   24 import Databrary.Has
   25 import Databrary.Files
   26 import Databrary.Model.Offset
   27 import Databrary.Model.Format
   28 import Databrary.Model.Asset
   29 import Databrary.Model.AssetSlot
   30 import Databrary.Model.AssetSegment
   31 import Databrary.Store.Types
   32 import Databrary.Store.Asset
   33 import Databrary.Store.Temp
   34 import Databrary.Store.AV
   35 -- import Databrary.Action.Types
   36 
   37 assetSegmentTag :: AssetSegment -> Maybe Word16 -> String
   38 assetSegmentTag as sz = m ':' ((assetSegmentFull as) `unlessUse` s) ++ m '@' (show <$> sz) where
   39   m = maybe "" . (:)
   40   c = assetSegmentRange as
   41   s = maybe (b (Range.lowerBound c) ++ '-' : b (Range.upperBound c)) (show . offsetMillis) (Range.getPoint c)
   42   b = maybe "" (show . offsetMillis) . Range.bound
   43 
   44 assetSegmentFile :: AssetSegment -> Maybe Word16 -> Maybe RawFilePath                                    
   45 assetSegmentFile as sz = (<> BSC.pack (assetSegmentTag as sz)) <$> assetFile (slotAsset $ segmentAsset as)
   46 
   47 type Stream = BS.ByteString -> IO ()
   48 
   49 stream :: Stream -> Handle -> IO ()
   50 stream s h = loop where
   51   loop = do
   52     b <- BS.hGetSome h defaultChunkSize
   53     s b                     
   54     unless (BS.null b) $ loop
   55 
   56 genVideoClip :: AV -> RawFilePath -> Maybe (Range.Range Offset) -> Maybe Word16 -> Either Stream RawFilePath -> IO ()
   57 genVideoClip _ src (Just clip) _ dst | Nothing <- Range.getPoint clip = do
   58   srcfp <- unRawFilePath src
   59   dstfp <- case dst of
   60     Left _ -> return "-"
   61     Right rp -> unRawFilePath rp
   62   print ("about to slice video file")
   63   let upperBoundArgs = maybe [] (\u -> ["-t", sb $ u - lb]) ub
   64   print ("ffmpeg","-y", "-accurate_seek", "-ss", sb lb, "-i", srcfp, upperBoundArgs, "-codec copy"
   65         , "-f mp4")
   66   P.withCheckedProcess (P.proc "ffmpeg" $
   67     [ "-y", "-accurate_seek"
   68     , "-loglevel", "error"
   69     , "-threads", "1"
   70     , "-ss", sb lb
   71     , "-i", srcfp ]
   72     ++ maybe [] (\u -> ["-t", sb $ u - lb]) ub ++
   73     [ "-codec", "copy"
   74     , "-f", "mp4"
   75     , dstfp ])
   76     { P.std_out = P.CreatePipe
   77     , P.close_fds = True
   78     }
   79     (\P.ClosedStream h P.Inherited ->
   80       either stream (const hClose) dst h)
   81   where
   82   lb = fromMaybe 0 $ Range.bound $ Range.lowerBound clip
   83   ub = Range.bound $ Range.upperBound clip
   84   sb = (showFixed True :: Milli -> String) . offsetMilli
   85 genVideoClip av src frame sz dst =
   86   avFrame src (offsetDiffTime <$> (Range.getPoint =<< frame)) sz Nothing (rightJust dst) av
   87     >>= mapM_ (\b -> send b >> send BS.empty)          
   88   where send = either id (const $ const $ return ()) dst
   89 
   90 getAssetSegmentStore
   91   :: (MonadStorage c m, MonadHas AV c m, MonadHas InternalState c m) => AssetSegment -> Maybe Word16 -> m (Either (Stream -> IO ()) RawFilePath)
   92 getAssetSegmentStore as sz
   93   | aimg && isJust sz || not (assetSegmentFull as) && isJust (assetDuration $ assetRow a) && isJust (formatSample afmt) = do
   94   liftIO $ print "need to slice off a segment"
   95   Just af <- getAssetFile a
   96   av <- peek
   97   store <- peek
   98   rs <- peek
   99   let cache = storageCache store                        
  100       cf = liftM2 (</>) cache $ assetSegmentFile as sz
  101       gen = genVideoClip av af (aimg `unlessUse` clip) sz
  102   liftIO $ maybe
  103     (return $ Left $ gen . Left) -- cache disabled or segment file missing(how could it be missing?)
  104     (\f -> do -- cache enabled
  105       print ("attempt to fetch prior cached slice or generate and cache slice")
  106       fe <- fileExist f
  107       when fe (print "found a cached slice, reusing!")
  108       unless fe $ do
  109         tf <- makeTempFileAs (maybe (storageTemp store) (</> "tmp/") cache) (const $ return ()) rs
  110         print ("generating cached slice at", tempFilePath tf)
  111         gen (Right (tempFilePath tf))
  112         _ <- createDir (takeDirectory f) 0o770
  113         setFileMode (tempFilePath tf) 0o640
  114         renameTempFile tf f rs
  115       return $ Right f)
  116     cf
  117   | otherwise = do
  118   liftIO $ print "can serve full file, unsliced"
  119   Right . fromJust <$> getAssetFile a
  120   where
  121   a = slotAsset $ segmentAsset as
  122   afmt = assetFormat $ assetRow a
  123   aimg = afmt == imageFormat
  124   clip = assetSegmentRange as