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