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