polysemy-video (empty) → 0.1.0.0

raw patch · 5 files changed

+157/−0 lines, 5 filesdep +basedep +formattingdep +path

Dependencies added: base, formatting, path, path-utils, polysemy, text, turtle

Files

ChangeLog.md +5/−0
LICENSE +19/−0
README.md +3/−0
polysemy-video.cabal +40/−0
src/Polysemy/Video.hs +90/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Changelog for polysemy-video++## v0.0.1.0++* Experimental DSL and interpreter.

+ LICENSE view

@@ -0,0 +1,19 @@+Copyright (c) 2020 Daniel Firth++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ README.md view

@@ -0,0 +1,3 @@+# polysemy-video++Experimental AV processing DSL for polysemy. Includes one interpretation to the command line version of ffmpeg.

+ polysemy-video.cabal view

@@ -0,0 +1,40 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           polysemy-video+version:        0.1.0.0+description:    Experimental video processing DSL for polysemy.+author:         Daniel Firth+maintainer:     dan.firth@homotopic.tech+copyright:      2020 Daniel Firth+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/homotopic-tech/polysemy-video++library+  exposed-modules:+      Polysemy.Video+  other-modules:+      Paths_polysemy_video+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , formatting+    , path+    , path-utils+    , polysemy+    , text+    , turtle+  default-language: Haskell2010

+ src/Polysemy/Video.hs view

@@ -0,0 +1,90 @@+{- |+   Module    : Polysemy.Video+   License   : MIT+   Stability : experimental++Experimental Video processing DSL for Polysemy.+-}+{-# 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++-- | Timestamp data type.+data Time = Time+  { hour    :: Int+  , minutes :: Int+  , seconds :: Int+  , frame   :: Int+  } deriving (Eq, Ord, Show)++-- | Interval of two timestamps.+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++-- | Format a Timestamp to ffmpeg's format 00:00:00.000.+timeFF :: Time -> Text+timeFF (Time h m s f) = sformat (int % ":" % int % ":" % int % "." % int) h m s f++-- | "-ss <x>" where x is a timestamp.+seekFF :: Time -> [Text]+seekFF t = ["-ss", timeFF t]++-- | "-ss <x> -to <y> <output>".+rangeFF :: Range -> Path Rel File -> [Text]+rangeFF (Range f t) x = seekFF f ++ ["-to", timeFF t, toFilePathText x]++-- | "-ss <x> -vframes 1 <output>"+frameFF :: Time -> Path Rel File -> [Text]+frameFF t x = seekFF t ++ ["-vframes", "1", toFilePathText x]++-- | "-i <output>"+inputFF :: Path Rel File -> [Text]+inputFF x = ["-i", toFilePathText x]++-- | "ffmpeg -y" followed by some arguments.+runffmpeg :: MonadIO m => [Text] -> m ()+runffmpeg xs = S.sh $ S.inproc "ffmpeg" ("-y" : xs) mempty++-- | "mkdir -p" with a `Path b Dir`.+mktreeFP :: MonadIO m => Path b Dir -> m ()+mktreeFP = S.mktree . S.decodeString . toFilePath++-- | Interpret `ClipProcess` by running it against ffmpeg on the command line.+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))++-- | Interpret `ClipProcess` by printing out the command it would have run to the terminal.+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)