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