1 {-# LANGUAGE RecordWildCards, OverloadedStrings, ViewPatterns #-}
    2 module 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 Ops
   25 import Has (view, peek, peeks, focusIO, MonadHas)
   26 import Service.DB (MonadDB)
   27 import Service.Log
   28 import HTTP.Route (routeURL)
   29 import Model.Audit (MonadAudit)
   30 import Model.Segment
   31 import Model.Asset
   32 import Model.AssetSlot
   33 import Model.Format
   34 import Model.Time
   35 import Model.Transcode
   36 import Files
   37 import Service.Types (Secret)
   38 import Store.Types
   39 import Store.Temp
   40 import Store.Asset
   41 import Store.Transcoder
   42 import Store.AV
   43 import Store.Probe
   44 import Action.Types
   45 import Action.Run
   46 
   47 import {-# SOURCE #-} 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)