1 {-# LANGUAGE OverloadedStrings #-} 2 module 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) 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 Ops 21 import Has (peeks) 22 import HTTP.Form.Deform 23 import HTTP.Path.Parser 24 import Action.Run 25 import Action 26 import Model.Id 27 import Model.Transcode 28 import Model.Asset 29 import Store.Transcode 30 import Controller.Paths 31 import Controller.Permission 32 import Controller.Form 33 import 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 data RemoteTranscodeResultRequest = 51 RemoteTranscodeResultRequest BS.ByteString (Maybe TranscodePID) Int (Maybe BS.ByteString) String 52 53 remoteTranscode :: ActionRoute (Id Transcode) 54 remoteTranscode = action POST (pathJSON >/> pathId) $ \ti -> withoutAuth $ do 55 t <- maybeAction =<< lookupTranscode ti 56 withReAuth (transcodeOwner t) $ do 57 auth <- peeks $ transcodeAuth t 58 RemoteTranscodeResultRequest _ _ res sha1 logs <- runForm Nothing $ do 59 reqAuth <- "auth" .:> (deformCheck "Invalid authentication" (constEq auth :: BS.ByteString -> Bool) =<< deform) 60 reqPid <- "pid" .:> (deformCheck "PID mismatch" (transcodeProcess t ==) =<< deformNonEmpty deform) 61 RemoteTranscodeResultRequest 62 <$> pure reqAuth 63 <*> pure reqPid 64 <*> ("res" .:> deform) 65 <*> ("sha1" .:> optional sha1Form) 66 <*> ("log" .:> deform) 67 collectTranscode t res sha1 logs 68 return $ okResponse [] BS.empty 69 70 viewTranscodes :: ActionRoute () 71 viewTranscodes = action GET (pathHTML >/> "admin" >/> "transcode") $ \() -> viewTranscodesHandler 72 73 viewTranscodesHandler :: Action -- TODO: GET only 74 viewTranscodesHandler = withAuth $ do 75 checkMemberADMIN 76 t <- lookupActiveTranscodes 77 peeks $ okResponse [] . htmlTranscodes t 78 79 data TranscodeAction 80 = TranscodeStart 81 | TranscodeStop 82 | TranscodeFail 83 deriving (Bounded, Enum) 84 85 instance Show TranscodeAction where 86 show TranscodeStart = "start" 87 show TranscodeStop = "stop" 88 show TranscodeFail = "fail" 89 90 instance Read TranscodeAction where 91 readsPrec _ s = mapMaybe (\t -> (,) t <$> stripPrefix (show t) s) $ enumFromTo minBound maxBound 92 93 instance Deform f TranscodeAction where 94 deform = deformRead TranscodeStart 95 96 data UpdateTranscodeRequest = UpdateTranscodeRequest TranscodeAction 97 98 postTranscode :: ActionRoute (Id Transcode) 99 postTranscode = action POST (pathHTML >/> "admin" >/> pathId) $ \ti -> withAuth $ do 100 t <- maybeAction =<< lookupTranscode ti 101 UpdateTranscodeRequest act <- runForm Nothing $ 102 UpdateTranscodeRequest <$> ("action" .:> deform) 103 case act of 104 TranscodeStart | isNothing (transcodeProcess t) -> void $ startTranscode t 105 TranscodeStop -> void $ stopTranscode t 106 TranscodeFail | isNothing (assetSize $ assetRow $ transcodeAsset t) -> void $ changeAsset (transcodeAsset t){ assetRow = (assetRow $ transcodeAsset t){ assetSize = Just (-1) } } Nothing 107 _ -> fail "Invalid action" 108 peeks $ otherRouteResponse [] viewTranscodes ()