module Store.AssetSegment
( assetSegmentTag
, getAssetSegmentStore
) where
import Control.Monad (unless, liftM2, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (InternalState)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import Data.Fixed (showFixed, Milli)
import Data.Maybe (isJust, fromMaybe, fromJust)
import Data.Monoid ((<>))
import Data.Word (Word16)
import qualified Data.Streaming.Process as P
import qualified Database.PostgreSQL.Typed.Range as Range
import System.IO (Handle, hClose)
import System.Posix.FilePath (takeDirectory)
import System.Posix.Files.ByteString (setFileMode, fileExist)
import Ops
import Has
import Files
import Model.Offset
import Model.Format
import Model.Asset
import Model.AssetSlot
import Model.AssetSegment
import Store.Types
import Store.Asset
import Store.Temp
import Store.AV
assetSegmentTag :: AssetSegment -> Maybe Word16 -> String
assetSegmentTag as sz = m ':' (assetSegmentFull as `unlessUse` s) ++ m '@' (show <$> sz) where
m = maybe "" . (:)
c = assetSegmentRange as
s = maybe (b (Range.lowerBound c) ++ '-' : b (Range.upperBound c)) (show . offsetMillis) (Range.getPoint c)
b = maybe "" (show . offsetMillis) . Range.bound
assetSegmentFile :: AssetSegment -> Maybe Word16 -> Maybe RawFilePath
assetSegmentFile as sz = (<> BSC.pack (assetSegmentTag as sz)) <$> assetFile (slotAsset $ segmentAsset as)
type Stream = BS.ByteString -> IO ()
stream :: Stream -> Handle -> IO ()
stream s h = loop where
loop = do
b <- BS.hGetSome h defaultChunkSize
s b
unless (BS.null b) loop
genVideoClip :: AV -> RawFilePath -> Maybe (Range.Range Offset) -> Maybe Word16 -> Either Stream RawFilePath -> IO ()
genVideoClip _ src (Just clip) _ dst | Nothing <- Range.getPoint clip = do
srcfp <- unRawFilePath src
dstfp <- case dst of
Left _ -> return "-"
Right rp -> unRawFilePath rp
print "about to slice video file"
let upperBoundArgs = maybe [] (\u -> ["-t", sb $ u lb]) ub
print ("ffmpeg","-y", "-accurate_seek", "-ss", sb lb, "-i", srcfp, upperBoundArgs, "-codec copy"
, "-f mp4")
P.withCheckedProcess (P.proc "ffmpeg" $
[ "-y", "-accurate_seek"
, "-loglevel", "error"
, "-threads", "1"
, "-ss", sb lb
, "-i", srcfp ]
++ maybe [] (\u -> ["-t", sb $ u lb]) ub ++
[ "-codec", "copy"
, "-f", "mp4"
, dstfp ])
{ P.std_out = P.CreatePipe
, P.close_fds = True
}
(\P.ClosedStream h P.Inherited ->
either stream (const hClose) dst h)
where
lb = fromMaybe 0 $ Range.bound $ Range.lowerBound clip
ub = Range.bound $ Range.upperBound clip
sb = (showFixed True :: Milli -> String) . offsetMilli
genVideoClip av src frame sz dst =
avFrame src (offsetDiffTime <$> (Range.getPoint =<< frame)) sz Nothing (rightJust dst) av
>>= mapM_ (\b -> send b >> send BS.empty)
where send = either id (const $ const $ return ()) dst
getAssetSegmentStore
:: (MonadStorage c m, MonadHas AV c m, MonadHas InternalState c m) => AssetSegment -> Maybe Word16 -> m (Either (Stream -> IO ()) RawFilePath)
getAssetSegmentStore as sz
| aimg && isJust sz || not (assetSegmentFull as) && isJust (assetDuration $ assetRow a) && isJust (formatSample afmt) = do
liftIO $ print "need to slice off a segment"
Just af <- getAssetFile a
av <- peek
store <- peek
rs <- peek
let cache = storageCache store
cf = liftM2 (</>) cache $ assetSegmentFile as sz
gen = genVideoClip av af (aimg `unlessUse` clip) sz
liftIO $ maybe
(return $ Left $ gen . Left)
(\f -> do
print "attempt to fetch prior cached slice or generate and cache slice"
fe <- fileExist f
when fe (print "found a cached slice, reusing!")
unless fe $ do
tf <- makeTempFileAs (maybe (storageTemp store) (</> "tmp/") cache) (const $ return ()) rs
print ("generating cached slice at", tempFilePath tf)
gen (Right (tempFilePath tf))
_ <- createDir (takeDirectory f) 0o770
setFileMode (tempFilePath tf) 0o640
renameTempFile tf f rs
return $ Right f)
cf
| otherwise = do
liftIO $ print "can serve full file, unsliced"
Right . fromJust <$> getAssetFile a
where
a = slotAsset $ segmentAsset as
afmt = assetFormat $ assetRow a
aimg = afmt == imageFormat
clip = assetSegmentRange as