{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Polysemy.Video where
import Control.Monad.IO.Class
import Data.Text (Text)
import qualified Data.Text as T
import Formatting
import Path
import Path.Utils
import Polysemy
import qualified Turtle as S
data Time = Time
{ hour :: Int
, minutes :: Int
, seconds :: Int
, frame :: Int
} deriving (Eq, Ord, Show)
data Range = Range
{ from :: Time
, to :: Time
} deriving (Eq, Ord, Show)
data ClipProcess m a where
ExtractAudio :: Path Rel File -> [(Range, Path Rel File)] -> ClipProcess m ()
ExtractClips :: Path Rel File -> [(Range, Path Rel File)] -> ClipProcess m ()
ExtractFrames :: Path Rel File -> [(Time, Path Rel File)] -> ClipProcess m ()
makeSem ''ClipProcess
timeFF :: Time -> Text
timeFF (Time h m s f) = sformat (int % ":" % int % ":" % int % "." % int) h m s f
seekFF :: Time -> [Text]
seekFF t = ["-ss", timeFF t]
rangeFF :: Range -> Path Rel File -> [Text]
rangeFF (Range f t) x = seekFF f ++ ["-to", timeFF t, toFilePathText x]
frameFF :: Time -> Path Rel File -> [Text]
frameFF t x = seekFF t ++ ["-vframes", "1", toFilePathText x]
inputFF :: Path Rel File -> [Text]
inputFF x = ["-i", toFilePathText x]
runffmpeg :: MonadIO m => [Text] -> m ()
runffmpeg xs = S.sh $ S.inproc "ffmpeg" ("-y" : xs) mempty
mktreeFP :: MonadIO m => Path b Dir -> m ()
mktreeFP = S.mktree . S.decodeString . toFilePath
interpretFFMpegCli :: Member (Embed IO) effs => Sem (ClipProcess ': effs) a -> Sem effs a
interpretFFMpegCli = interpret $ \case
ExtractAudio x ts -> mapM_ mktreeFP (parent . snd <$> ts) >> runffmpeg (inputFF x <> (uncurry rangeFF =<< ts))
ExtractClips x ts -> mapM_ mktreeFP (parent . snd <$> ts) >> runffmpeg (inputFF x <> (uncurry rangeFF =<< ts))
ExtractFrames x ts -> mapM_ mktreeFP (parent . snd <$> ts) >> runffmpeg (inputFF x <> (uncurry frameFF =<< ts))
interpretFFMpegNoop :: Member (Embed IO) effs => Sem (ClipProcess ': effs) a -> Sem effs a
interpretFFMpegNoop = interpret $ \case
ExtractAudio x ts -> embed $ print $ T.unwords $ inputFF x <> (uncurry rangeFF =<< ts)
ExtractClips x ts -> embed $ print $ T.unwords $ inputFF x <> (uncurry rangeFF =<< ts)
ExtractFrames x ts -> embed $ print $ T.unwords $ inputFF x <> (uncurry frameFF =<< ts)