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 ()