1 {-# LANGUAGE RecordWildCards, OverloadedStrings, ViewPatterns #-} 2 module Databrary.Store.Transcode 3 ( startTranscode 4 , forkTranscode 5 , stopTranscode 6 , collectTranscode 7 , transcodeEnabled 8 ) where 9 10 import Control.Concurrent (ThreadId) 11 import Control.Monad (guard, unless, void) 12 import Control.Monad.IO.Class (liftIO) 13 import Control.Monad.Trans.Resource (InternalState) 14 import qualified Data.ByteString as BS 15 import qualified Data.ByteString.Builder as BSB 16 import qualified Data.ByteString.Char8 as BSC 17 import qualified Data.ByteString.Lazy.Char8 as BSLC 18 import Data.Maybe (fromMaybe, isNothing) 19 import Data.Monoid ((<>)) 20 import System.Exit (ExitCode(..)) 21 import Text.Read (readMaybe) 22 import qualified Web.Route.Invertible as R 23 24 import Databrary.Ops 25 import Databrary.Has (view, peek, peeks, focusIO, MonadHas) 26 import Databrary.Service.DB (MonadDB) 27 import Databrary.Service.Log 28 import Databrary.HTTP.Route (routeURL) 29 import Databrary.Model.Audit (MonadAudit) 30 import Databrary.Model.Segment 31 import Databrary.Model.Asset 32 import Databrary.Model.AssetSlot 33 import Databrary.Model.Format 34 import Databrary.Model.Time 35 import Databrary.Model.Transcode 36 import Databrary.Files 37 import Databrary.Service.Types (Secret) 38 import Databrary.Store.Types 39 import Databrary.Store.Temp 40 import Databrary.Store.Asset 41 import Databrary.Store.Transcoder 42 import Databrary.Store.AV 43 import Databrary.Store.Probe 44 import Databrary.Action.Types 45 import Databrary.Action.Run 46 47 import {-# SOURCE #-} Databrary.Controller.Transcode 48 49 ctlTranscode :: (MonadDB c m, MonadHas Timestamp c m, MonadLog c m, MonadStorage c m) => Transcode -> TranscodeArgs -> m (ExitCode, String, String) 50 ctlTranscode tc args = do 51 t <- peek 52 Just ctl <- peeks storageTranscoder 53 let args' 54 = "-i" : show (transcodeId tc) 55 : "-f" : BSC.unpack (head $ formatExtension $ assetFormat $ assetRow $ transcodeAsset tc) 56 : args 57 r@(c, o, e) <- liftIO $ runTranscoder ctl args' 58 focusIO $ logMsg t ("transcode " ++ unwords args' ++ ": " ++ case c of { ExitSuccess -> "" ; ExitFailure i -> ": exit " ++ show i ++ "\n" } ++ o ++ e) 59 return r 60 61 transcodeArgs :: (MonadStorage c m, MonadHas Secret c m, MonadAudit c m) => Transcode -> m TranscodeArgs 62 transcodeArgs t@Transcode{..} = do 63 Just f <- getAssetFile (transcodeOrig t) 64 req <- peek 65 auth <- peeks $ transcodeAuth t 66 fp <- liftIO $ unRawFilePath f 67 return $ 68 [ "-s", fp 69 , "-r", BSLC.unpack $ BSB.toLazyByteString $ routeURL (Just req) (R.requestActionRoute remoteTranscode (transcodeId t)) [("auth", Just auth)] 70 , "--" ] 71 ++ maybe [] (\l -> ["-ss", show l]) lb 72 ++ maybe [] (\u -> ["-t", show $ u - fromMaybe 0 lb]) (upperBound rng) 73 ++ transcodeOptions 74 where 75 rng = segmentRange transcodeSegment 76 lb = lowerBound rng 77 78 startTranscode :: (MonadStorage c m, MonadHas Secret c m, MonadAudit c m, MonadHas Timestamp c m, MonadLog c m) => Transcode -> m (Maybe TranscodePID) 79 startTranscode tc = do 80 tc' <- updateTranscode tc lock Nothing 81 unless (transcodeProcess tc' == lock) $ fail $ "startTranscode " ++ show (transcodeId tc) 82 findMatchingTranscode tc >>= maybe 83 (do 84 args <- transcodeArgs tc 85 (r, out, err) <- ctlTranscode tc' args 86 let pid = guard (r == ExitSuccess) >> readMaybe out 87 _ <- updateTranscode tc' pid $ ((isNothing pid) `thenUse` out) <> ((null err) `unlessUse` err) 88 return pid) 89 (\(transcodeAsset -> match) -> do 90 a <- changeAsset (transcodeAsset tc) 91 { assetRow = (assetRow $ transcodeAsset tc) 92 { assetSHA1 = assetSHA1 $ assetRow match 93 , assetDuration = assetDuration $ assetRow match 94 , assetSize = assetSize $ assetRow match 95 } 96 } Nothing 97 void $ changeAssetSlotDuration a 98 _ <- updateTranscode tc' Nothing (Just $ "reuse " ++ show (assetId $ assetRow match)) 99 return Nothing) 100 where lock = Just (-1) 101 102 forkTranscode :: Transcode -> Handler ThreadId 103 forkTranscode tc = focusIO $ \ctx -> 104 forkAction 105 (startTranscode tc) ctx 106 (either 107 (\e -> logMsg (view ctx) ("forkTranscode: " ++ show e) (view ctx)) 108 (const $ return ())) 109 110 stopTranscode :: (MonadDB c m, MonadHas Timestamp c m, MonadLog c m, MonadStorage c m) => Transcode -> m Transcode 111 stopTranscode tc@Transcode{ transcodeProcess = Just pid } | pid >= 0 = do 112 tc' <- updateTranscode tc Nothing (Just "aborted") 113 (r, out, err) <- ctlTranscode tc ["-k", show pid] 114 unless (r == ExitSuccess) $ 115 fail ("stopTranscode: " ++ out ++ err) 116 return tc' 117 stopTranscode tc = return tc 118 119 collectTranscode 120 :: (MonadHas AV c m, MonadDB c m, MonadHas InternalState c m, MonadLog c m, MonadStorage c m, MonadHas Timestamp c m, MonadAudit c m) 121 => Transcode -> Int -> Maybe BS.ByteString -> String -> m () 122 collectTranscode tc 0 sha1 logs = do 123 tc' <- updateTranscode tc (Just (-2)) (Just logs) 124 f <- makeTempFile (const $ return ()) 125 (r, out, err) <- ctlTranscode tc ["-c", BSC.unpack $ tempFilePath f] 126 _ <- updateTranscode tc' Nothing (Just $ out ++ err) 127 if r /= ExitSuccess 128 then fail $ "collectTranscode " ++ show (transcodeId tc) ++ ": " ++ show r ++ "\n" ++ out ++ err 129 else do 130 av <- focusIO $ avProbe (tempFilePath f) 131 unless (avProbeCheckFormat (assetFormat $ assetRow $ transcodeAsset tc) av) 132 $ fail $ "collectTranscode " ++ show (transcodeId tc) ++ ": format error" 133 let dur = avProbeLength av 134 a <- changeAsset (transcodeAsset tc) 135 { assetRow = (assetRow $ transcodeAsset tc) 136 { assetSHA1 = sha1 137 , assetDuration = dur 138 } 139 } (Just $ tempFilePath f) 140 focusIO $ releaseTempFile f 141 void $ changeAssetSlotDuration a 142 collectTranscode tc e _ logs = 143 void $ updateTranscode tc Nothing (Just $ "exit " ++ show e ++ '\n' : logs)