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