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)