1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Controller.Transcode
    3   ( remoteTranscode
    4   -- , viewTranscodes
    5   , viewTranscodesHandler
    6   , TranscodeAction(..)
    7   , postTranscode
    8   ) where
    9 
   10 import Control.Applicative (optional)
   11 import Control.Monad (void, liftM3)
   12 import Data.Bits (shiftL, (.|.))
   13 import Data.ByteArray (constEq)
   14 import qualified Data.ByteString as BS
   15 import Data.Char (isHexDigit, digitToInt)
   16 import Data.List (stripPrefix)
   17 import Data.Maybe (isNothing, mapMaybe)
   18 import Data.Word (Word8)
   19 
   20 import Databrary.Ops
   21 import Databrary.Has (peeks)
   22 import Databrary.HTTP.Form.Deform
   23 import Databrary.HTTP.Path.Parser
   24 import Databrary.Action.Run
   25 import Databrary.Action
   26 import Databrary.Model.Id
   27 import Databrary.Model.Transcode
   28 import Databrary.Model.Asset
   29 import Databrary.Store.Transcode
   30 import Databrary.Controller.Paths
   31 import Databrary.Controller.Permission
   32 import Databrary.Controller.Form
   33 import Databrary.View.Transcode
   34 
   35 unHex :: String -> Maybe [Word8]
   36 unHex [] = Just []
   37 unHex [_] = Nothing
   38 unHex (h:l:r) = do
   39   hb <- unhex h
   40   lb <- unhex l
   41   ((shiftL hb 4 .|. lb) :) <$> unHex r
   42   where unhex x = (isHexDigit x) `thenUse` (fromIntegral (digitToInt x))
   43 
   44 sha1Form :: DeformHandler f BS.ByteString
   45 sha1Form = do
   46   b <- deform
   47   deformGuard "Invalid SHA1 hex string" (length b == 40)
   48   maybe (deformError "Invalid hex string" >> return BS.empty) (return . BS.pack) $ unHex b
   49 
   50 remoteTranscode :: ActionRoute (Id Transcode)
   51 remoteTranscode = action POST (pathJSON >/> pathId) $ \ti -> withoutAuth $ do
   52   t <- maybeAction =<< lookupTranscode ti
   53   withReAuth (transcodeOwner t) $ do
   54     auth <- peeks $ transcodeAuth t
   55     (res, sha1, logs) <- runForm Nothing $ do
   56       _ <- "auth" .:> (deformCheck "Invalid authentication" (constEq auth :: BS.ByteString -> Bool) =<< deform)
   57       _ <- "pid" .:> (deformCheck "PID mismatch" (transcodeProcess t ==) =<< deformNonEmpty deform)
   58       liftM3 (,,)
   59         ("res" .:> deform)
   60         ("sha1" .:> optional sha1Form)
   61         ("log" .:> deform)
   62     collectTranscode t res sha1 logs
   63     return $ okResponse [] BS.empty
   64 
   65 viewTranscodes :: ActionRoute ()
   66 viewTranscodes = action GET (pathHTML >/> "admin" >/> "transcode") $ \() -> viewTranscodesHandler
   67 
   68 viewTranscodesHandler :: Action -- TODO: GET only
   69 viewTranscodesHandler = withAuth $ do
   70   checkMemberADMIN
   71   t <- lookupActiveTranscodes
   72   peeks $ okResponse [] . htmlTranscodes t
   73 
   74 data TranscodeAction
   75   = TranscodeStart
   76   | TranscodeStop
   77   | TranscodeFail
   78   deriving (Bounded, Enum)
   79 
   80 instance Show TranscodeAction where
   81   show TranscodeStart = "start"
   82   show TranscodeStop = "stop"
   83   show TranscodeFail = "fail"
   84 
   85 instance Read TranscodeAction where
   86   readsPrec _ s = mapMaybe (\t -> (,) t <$> stripPrefix (show t) s) $ enumFromTo minBound maxBound
   87 
   88 instance Deform f TranscodeAction where
   89   deform = deformRead TranscodeStart
   90 
   91 postTranscode :: ActionRoute (Id Transcode)
   92 postTranscode = action POST (pathHTML >/> "admin" >/> pathId) $ \ti -> withAuth $ do
   93   t <- maybeAction =<< lookupTranscode ti
   94   act <- runForm Nothing $
   95     "action" .:> deform
   96   case act of
   97     TranscodeStart | isNothing (transcodeProcess t) -> void $ startTranscode t
   98     TranscodeStop -> void $ stopTranscode t
   99     TranscodeFail | isNothing (assetSize $ assetRow $ transcodeAsset t) -> void $ changeAsset (transcodeAsset t){ assetRow = (assetRow $ transcodeAsset t){ assetSize = Just (-1) } } Nothing
  100     _ -> fail "Invalid action"
  101   peeks $ otherRouteResponse [] viewTranscodes ()