{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts, RecordWildCards #-}
-- | Video decoding API. Includes FFI declarations for the underlying
-- FFmpeg functions, wrappers for these functions that wrap error
-- condition checking, and high level Haskellized interfaces.
module Codec.FFmpeg.Decode where
import Codec.FFmpeg.Common
import Codec.FFmpeg.Enums
import Codec.FFmpeg.Scaler
import Codec.FFmpeg.Types
import Control.Arrow (first)
import Control.Monad (when, void)
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca, free, mallocBytes)
import Foreign.Marshal.Array (advancePtr)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable

-- * FFI Declarations

foreign import ccall "avformat_open_input"
  avformat_open_input :: Ptr AVFormatContext -> CString -> Ptr AVInputFormat
                      -> Ptr AVDictionary -> IO CInt

foreign import ccall "avformat_find_stream_info"
  avformat_find_stream_info :: AVFormatContext -> Ptr () -> IO CInt

foreign import ccall "av_find_best_stream"
  av_find_best_stream :: AVFormatContext -> AVMediaType -> CInt -> CInt
                      -> Ptr AVCodec -> CInt -> IO CInt

foreign import ccall "avcodec_find_decoder"
   avcodec_find_decoder :: AVCodecID -> IO AVCodec

foreign import ccall "avcodec_find_decoder_by_name"
  avcodec_find_decoder_by_name :: CString -> IO AVCodec

foreign import ccall "avpicture_get_size"
  avpicture_get_size :: AVPixelFormat -> CInt -> CInt -> IO CInt

foreign import ccall "av_malloc"
  av_malloc :: CSize -> IO (Ptr ())

foreign import ccall "av_read_frame"
  av_read_frame :: AVFormatContext -> AVPacket -> IO CInt

foreign import ccall "avcodec_decode_video2"
  decode_video :: AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket
               -> IO CInt
foreign import ccall "avformat_close_input"
  close_input :: Ptr AVFormatContext -> IO ()

foreign import ccall "av_dict_set"
  av_dict_set :: Ptr AVDictionary -> CString -> CString -> CInt -> IO CInt

foreign import ccall "av_find_input_format"
  av_find_input_format :: CString -> IO (Ptr AVInputFormat)

foreign import ccall "av_format_set_video_codec"
  av_format_set_video_codec :: AVFormatContext -> AVCodec -> IO ()

dictSet :: Ptr AVDictionary -> String -> String -> IO ()
dictSet :: Ptr AVDictionary -> String -> String -> IO ()
dictSet d :: Ptr AVDictionary
d k :: String
k v :: String
v = do
  CInt
r <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
k ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \k' :: CString
k' -> String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
v ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \v' :: CString
v' ->
         Ptr AVDictionary -> CString -> CString -> CInt -> IO CInt
av_dict_set Ptr AVDictionary
d CString
k' CString
v' 0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    CInt -> IO String
stringError CInt
r IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \err :: String
err ->
       String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "av_dict_set failed("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++"): "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
kString -> String -> String
forall a. [a] -> [a] -> [a]
++" => "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
v

-- * FFmpeg Decoding Interface

-- | Open the first video input device enumerated by FFMPEG.
openCamera :: (MonadIO m, MonadError String m) => String -> CameraConfig -> m AVFormatContext
openCamera :: String -> CameraConfig -> m AVFormatContext
openCamera cam :: String
cam cfg :: CameraConfig
cfg =
  IO AVFormatContext -> m AVFormatContext
forall (m :: * -> *) a.
(MonadIO m, MonadError String m) =>
IO a -> m a
wrapIOError (IO AVFormatContext -> m AVFormatContext)
-> ((Ptr AVFormatContext -> IO AVFormatContext)
    -> IO AVFormatContext)
-> (Ptr AVFormatContext -> IO AVFormatContext)
-> m AVFormatContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr AVFormatContext -> IO AVFormatContext) -> IO AVFormatContext
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVFormatContext -> IO AVFormatContext) -> m AVFormatContext)
-> (Ptr AVFormatContext -> IO AVFormatContext) -> m AVFormatContext
forall a b. (a -> b) -> a -> b
$ \ctx :: Ptr AVFormatContext
ctx ->
    String -> (CString -> IO AVFormatContext) -> IO AVFormatContext
forall a. String -> (CString -> IO a) -> IO a
withCString String
cam ((CString -> IO AVFormatContext) -> IO AVFormatContext)
-> (CString -> IO AVFormatContext) -> IO AVFormatContext
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr ->
      do AVFormatContext
avPtr <- IO AVFormatContext
mallocAVFormatContext
         AVFormatContext -> String -> IO ()
setupCamera AVFormatContext
avPtr String
cam
         Ptr AVFormatContext -> AVFormatContext -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr AVFormatContext
ctx AVFormatContext
avPtr
         Ptr AVInputFormat
fmt <- case CameraConfig -> Maybe String
format CameraConfig
cfg of
                  Just "mjpeg" -> String
-> (CString -> IO (Ptr AVInputFormat)) -> IO (Ptr AVInputFormat)
forall a. String -> (CString -> IO a) -> IO a
withCString "v4l2" CString -> IO (Ptr AVInputFormat)
av_find_input_format
                  Just f :: String
f -> String
-> (CString -> IO (Ptr AVInputFormat)) -> IO (Ptr AVInputFormat)
forall a. String -> (CString -> IO a) -> IO a
withCString String
f CString -> IO (Ptr AVInputFormat)
av_find_input_format
                  Nothing -> Ptr AVInputFormat -> IO (Ptr AVInputFormat)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr AVInputFormat
forall a. Ptr a
nullPtr
         CInt
r <- (Ptr AVDictionary -> IO CInt) -> IO CInt
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVDictionary -> IO CInt) -> IO CInt)
-> (Ptr AVDictionary -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \dict :: Ptr AVDictionary
dict -> do
                Ptr AVDictionary -> CameraConfig -> IO ()
setConfig Ptr AVDictionary
dict CameraConfig
cfg
                Ptr AVFormatContext
-> CString -> Ptr AVInputFormat -> Ptr AVDictionary -> IO CInt
avformat_open_input Ptr AVFormatContext
ctx CString
cstr Ptr AVInputFormat
fmt Ptr AVDictionary
dict
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           CInt -> IO String
stringError CInt
r IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \err :: String
err ->
             String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("ffmpeg failed opening file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
         Ptr AVFormatContext -> IO AVFormatContext
forall a. Storable a => Ptr a -> IO a
peek Ptr AVFormatContext
ctx
  where
    run :: (a -> IO b) -> Maybe a -> IO ()
    run :: (a -> IO b) -> Maybe a -> IO ()
run _ Nothing  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    run f :: a -> IO b
f (Just x :: a
x) = IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (a -> IO b
f a
x)

    setConfig :: Ptr AVDictionary -> CameraConfig -> IO ()
    setConfig :: Ptr AVDictionary -> CameraConfig -> IO ()
setConfig dict :: Ptr AVDictionary
dict (CameraConfig {..}) =
      do (Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> IO b) -> Maybe a -> IO ()
run (Ptr AVDictionary -> String -> String -> IO ()
dictSet Ptr AVDictionary
dict "framerate" (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) Maybe Int
framerate
         ((Int, Int) -> IO ()) -> Maybe (Int, Int) -> IO ()
forall a b. (a -> IO b) -> Maybe a -> IO ()
run (\(w :: Int
w,h :: Int
h) -> Ptr AVDictionary -> String -> String -> IO ()
dictSet Ptr AVDictionary
dict "video_size" (Int -> String
forall a. Show a => a -> String
show Int
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ "x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h)) Maybe (Int, Int)
resolution

    setupCamera :: AVFormatContext -> String -> IO ()
    setupCamera :: AVFormatContext -> String -> IO ()
setupCamera avfc :: AVFormatContext
avfc c :: String
c =
      do AVFormatContext -> IO ()
setCamera AVFormatContext
avfc
         AVFormatContext -> String -> IO ()
setFilename AVFormatContext
avfc String
c
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CameraConfig -> Maybe String
format CameraConfig
cfg Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "mjpeg") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
           AVCodec
mjpeg <- AVCodecID -> IO AVCodec
avcodec_find_decoder AVCodecID
avCodecIdMjpeg
           AVFormatContext -> AVCodecID -> IO ()
forall t. HasVideoCodecID t => t -> AVCodecID -> IO ()
setVideoCodecID AVFormatContext
avfc AVCodecID
avCodecIdMjpeg
           AVFormatContext -> AVCodec -> IO ()
av_format_set_video_codec AVFormatContext
avfc AVCodec
mjpeg

openInput :: (MonadIO m, MonadError String m) => InputSource -> m AVFormatContext
openInput :: InputSource -> m AVFormatContext
openInput ipt :: InputSource
ipt =
  case InputSource
ipt of
    File fileName :: String
fileName -> String -> m AVFormatContext
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> m AVFormatContext
openFile String
fileName
    Camera cam :: String
cam cf :: CameraConfig
cf -> String -> CameraConfig -> m AVFormatContext
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> CameraConfig -> m AVFormatContext
openCamera String
cam CameraConfig
cf

-- | Open an input media file.
openFile :: (MonadIO m, MonadError String m) => String -> m AVFormatContext
openFile :: String -> m AVFormatContext
openFile filename :: String
filename =
  IO AVFormatContext -> m AVFormatContext
forall (m :: * -> *) a.
(MonadIO m, MonadError String m) =>
IO a -> m a
wrapIOError (IO AVFormatContext -> m AVFormatContext)
-> ((Ptr AVFormatContext -> IO AVFormatContext)
    -> IO AVFormatContext)
-> (Ptr AVFormatContext -> IO AVFormatContext)
-> m AVFormatContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr AVFormatContext -> IO AVFormatContext) -> IO AVFormatContext
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVFormatContext -> IO AVFormatContext) -> m AVFormatContext)
-> (Ptr AVFormatContext -> IO AVFormatContext) -> m AVFormatContext
forall a b. (a -> b) -> a -> b
$ \ctx :: Ptr AVFormatContext
ctx ->
    String -> (CString -> IO AVFormatContext) -> IO AVFormatContext
forall a. String -> (CString -> IO a) -> IO a
withCString String
filename ((CString -> IO AVFormatContext) -> IO AVFormatContext)
-> (CString -> IO AVFormatContext) -> IO AVFormatContext
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr ->
      do Ptr (Ptr Any) -> Ptr Any -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr AVFormatContext -> Ptr (Ptr Any)
forall a b. Ptr a -> Ptr b
castPtr Ptr AVFormatContext
ctx) Ptr Any
forall a. Ptr a
nullPtr
         CInt
r <- Ptr AVFormatContext
-> CString -> Ptr AVInputFormat -> Ptr AVDictionary -> IO CInt
avformat_open_input Ptr AVFormatContext
ctx CString
cstr Ptr AVInputFormat
forall a. Ptr a
nullPtr Ptr AVDictionary
forall a. Ptr a
nullPtr
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (CInt -> IO String
stringError CInt
r IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: String
s ->
                          String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "ffmpeg failed opening file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
         Ptr AVFormatContext -> IO AVFormatContext
forall a. Storable a => Ptr a -> IO a
peek Ptr AVFormatContext
ctx

-- | @AVFrame@ is a superset of @AVPicture@, so we can upcast an
-- 'AVFrame' to an 'AVPicture'.
frameAsPicture :: AVFrame -> AVPicture
frameAsPicture :: AVFrame -> AVPicture
frameAsPicture = Ptr () -> AVPicture
AVPicture (Ptr () -> AVPicture)
-> (AVFrame -> Ptr ()) -> AVFrame -> AVPicture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr

-- | Find a codec given by name.
findDecoder :: (MonadIO m, MonadError String m) => String -> m AVCodec
findDecoder :: String -> m AVCodec
findDecoder name :: String
name =
  do AVCodec
r <- IO AVCodec -> m AVCodec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AVCodec -> m AVCodec) -> IO AVCodec -> m AVCodec
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO AVCodec) -> IO AVCodec
forall a. String -> (CString -> IO a) -> IO a
withCString String
name CString -> IO AVCodec
avcodec_find_decoder_by_name
     Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AVCodec -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVCodec
r Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr)
          (String -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Unsupported codec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name)
     AVCodec -> m AVCodec
forall (m :: * -> *) a. Monad m => a -> m a
return AVCodec
r

-- | Read packets of a media file to get stream information. This is
-- useful for file formats with no headers such as MPEG.
checkStreams :: (MonadIO m, MonadError String m) => AVFormatContext -> m ()
checkStreams :: AVFormatContext -> m ()
checkStreams ctx :: AVFormatContext
ctx =
  do CInt
r <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ AVFormatContext -> Ptr () -> IO CInt
avformat_find_stream_info AVFormatContext
ctx Ptr ()
forall a. Ptr a
nullPtr
     Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Couldn't find stream information")

-- | Searches for a video stream in an 'AVFormatContext'. If one is
-- found, returns the index of the stream in the container, and its
-- associated 'AVCodecContext' and 'AVCodec'.
findVideoStream :: (MonadIO m, MonadError String m)
                => AVFormatContext
                -> m (CInt, AVCodecContext, AVCodec, AVStream)
findVideoStream :: AVFormatContext -> m (CInt, AVCodecContext, AVCodec, AVStream)
findVideoStream fmt :: AVFormatContext
fmt = do
  IO (CInt, AVCodecContext, AVCodec, AVStream)
-> m (CInt, AVCodecContext, AVCodec, AVStream)
forall (m :: * -> *) a.
(MonadIO m, MonadError String m) =>
IO a -> m a
wrapIOError (IO (CInt, AVCodecContext, AVCodec, AVStream)
 -> m (CInt, AVCodecContext, AVCodec, AVStream))
-> ((Ptr AVCodec -> IO (CInt, AVCodecContext, AVCodec, AVStream))
    -> IO (CInt, AVCodecContext, AVCodec, AVStream))
-> (Ptr AVCodec -> IO (CInt, AVCodecContext, AVCodec, AVStream))
-> m (CInt, AVCodecContext, AVCodec, AVStream)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr AVCodec -> IO (CInt, AVCodecContext, AVCodec, AVStream))
-> IO (CInt, AVCodecContext, AVCodec, AVStream)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVCodec -> IO (CInt, AVCodecContext, AVCodec, AVStream))
 -> m (CInt, AVCodecContext, AVCodec, AVStream))
-> (Ptr AVCodec -> IO (CInt, AVCodecContext, AVCodec, AVStream))
-> m (CInt, AVCodecContext, AVCodec, AVStream)
forall a b. (a -> b) -> a -> b
$ \codec :: Ptr AVCodec
codec -> do
      Ptr AVCodec -> AVCodec -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr AVCodec
codec (Ptr () -> AVCodec
AVCodec Ptr ()
forall a. Ptr a
nullPtr)
      CInt
i <- AVFormatContext
-> AVMediaType -> CInt -> CInt -> Ptr AVCodec -> CInt -> IO CInt
av_find_best_stream AVFormatContext
fmt AVMediaType
avmediaTypeVideo (-1) (-1) Ptr AVCodec
codec 0
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
i CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Couldn't find a video stream")
      AVCodec
cod <- Ptr AVCodec -> IO AVCodec
forall a. Storable a => Ptr a -> IO a
peek Ptr AVCodec
codec
      Ptr AVStream
streams <- AVFormatContext -> IO (Ptr AVStream)
forall t. HasStreams t => t -> IO (Ptr AVStream)
getStreams AVFormatContext
fmt
      AVStream
vidStream <- Ptr AVStream -> IO AVStream
forall a. Storable a => Ptr a -> IO a
peek (Ptr AVStream -> Int -> Ptr AVStream
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr AVStream
streams (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
i))
      AVCodecContext
ctx <- AVStream -> IO AVCodecContext
forall t. HasCodecContext t => t -> IO AVCodecContext
getCodecContext AVStream
vidStream
      (CInt, AVCodecContext, AVCodec, AVStream)
-> IO (CInt, AVCodecContext, AVCodec, AVStream)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
i, AVCodecContext
ctx, AVCodec
cod, AVStream
vidStream)

-- | Find a registered decoder with a codec ID matching that found in
-- the given 'AVCodecContext'.
getDecoder :: (MonadIO m, MonadError String m)
           => AVCodecContext -> m AVCodec
getDecoder :: AVCodecContext -> m AVCodec
getDecoder ctx :: AVCodecContext
ctx = do AVCodec
p <- IO AVCodec -> m AVCodec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AVCodec -> m AVCodec) -> IO AVCodec -> m AVCodec
forall a b. (a -> b) -> a -> b
$ AVCodecContext -> IO AVCodecID
forall t. HasCodecID t => t -> IO AVCodecID
getCodecID AVCodecContext
ctx IO AVCodecID -> (AVCodecID -> IO AVCodec) -> IO AVCodec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVCodecID -> IO AVCodec
avcodec_find_decoder
                    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AVCodec -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVCodec
p Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr) (String -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Unsupported codec")
                    AVCodec -> m AVCodec
forall (m :: * -> *) a. Monad m => a -> m a
return AVCodec
p

-- | Initialize the given 'AVCodecContext' to use the given
-- 'AVCodec'. **NOTE**: This function is not thread safe!
openCodec :: (MonadIO m, MonadError String m)
          => AVCodecContext -> AVCodec -> m AVDictionary
openCodec :: AVCodecContext -> AVCodec -> m AVDictionary
openCodec ctx :: AVCodecContext
ctx cod :: AVCodec
cod =
  IO AVDictionary -> m AVDictionary
forall (m :: * -> *) a.
(MonadIO m, MonadError String m) =>
IO a -> m a
wrapIOError (IO AVDictionary -> m AVDictionary)
-> ((Ptr AVDictionary -> IO AVDictionary) -> IO AVDictionary)
-> (Ptr AVDictionary -> IO AVDictionary)
-> m AVDictionary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr AVDictionary -> IO AVDictionary) -> IO AVDictionary
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVDictionary -> IO AVDictionary) -> m AVDictionary)
-> (Ptr AVDictionary -> IO AVDictionary) -> m AVDictionary
forall a b. (a -> b) -> a -> b
$ \dict :: Ptr AVDictionary
dict -> do
    Ptr AVDictionary -> AVDictionary -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr AVDictionary
dict (Ptr () -> AVDictionary
AVDictionary Ptr ()
forall a. Ptr a
nullPtr)
    CInt
r <- AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt
open_codec AVCodecContext
ctx AVCodec
cod Ptr AVDictionary
dict
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Couldn't open decoder")
    Ptr AVDictionary -> IO AVDictionary
forall a. Storable a => Ptr a -> IO a
peek Ptr AVDictionary
dict

-- | Return the next frame of a stream.
read_frame_check :: AVFormatContext -> AVPacket -> IO ()
read_frame_check :: AVFormatContext -> AVPacket -> IO ()
read_frame_check ctx :: AVFormatContext
ctx pkt :: AVPacket
pkt = do CInt
r <- AVFormatContext -> AVPacket -> IO CInt
av_read_frame AVFormatContext
ctx AVPacket
pkt
                              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Frame read failed")

-- | Read frames of the given 'AVPixelFormat' from a video stream.
frameReader :: (MonadIO m, MonadError String m)
            => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ())
frameReader :: AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ())
frameReader dstFmt :: AVPixelFormat
dstFmt ipt :: InputSource
ipt =
  do AVFormatContext
inputContext <- InputSource -> m AVFormatContext
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
InputSource -> m AVFormatContext
openInput InputSource
ipt
     AVFormatContext -> m ()
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext -> m ()
checkStreams AVFormatContext
inputContext
     (vidStreamIndex :: CInt
vidStreamIndex, ctx :: AVCodecContext
ctx, cod :: AVCodec
cod, _vidStream :: AVStream
_vidStream) <- AVFormatContext -> m (CInt, AVCodecContext, AVCodec, AVStream)
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext -> m (CInt, AVCodecContext, AVCodec, AVStream)
findVideoStream AVFormatContext
inputContext
     AVDictionary
_ <- AVCodecContext -> AVCodec -> m AVDictionary
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVCodecContext -> AVCodec -> m AVDictionary
openCodec AVCodecContext
ctx AVCodec
cod
     AVFormatContext
-> CInt
-> AVPixelFormat
-> AVCodecContext
-> m (IO (Maybe AVFrame), IO ())
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext
-> CInt
-> AVPixelFormat
-> AVCodecContext
-> m (IO (Maybe AVFrame), IO ())
prepareReader AVFormatContext
inputContext CInt
vidStreamIndex AVPixelFormat
dstFmt AVCodecContext
ctx

-- | Read RGB frames with the result in the 'MaybeT' transformer.
--
-- > frameReaderT = fmap (first MaybeT) . frameReader
frameReaderT :: (Functor m, MonadIO m, MonadError String m)
             => InputSource -> m (MaybeT IO AVFrame, IO ())
frameReaderT :: InputSource -> m (MaybeT IO AVFrame, IO ())
frameReaderT = ((IO (Maybe AVFrame), IO ()) -> (MaybeT IO AVFrame, IO ()))
-> m (IO (Maybe AVFrame), IO ()) -> m (MaybeT IO AVFrame, IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO (Maybe AVFrame) -> MaybeT IO AVFrame)
-> (IO (Maybe AVFrame), IO ()) -> (MaybeT IO AVFrame, IO ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first IO (Maybe AVFrame) -> MaybeT IO AVFrame
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT) (m (IO (Maybe AVFrame), IO ()) -> m (MaybeT IO AVFrame, IO ()))
-> (InputSource -> m (IO (Maybe AVFrame), IO ()))
-> InputSource
-> m (MaybeT IO AVFrame, IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ())
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ())
frameReader AVPixelFormat
avPixFmtRgb24

-- | Read time stamped frames of the given 'AVPixelFormat' from a
-- video stream. Time is given in seconds from the start of the
-- stream.
frameReaderTime :: (MonadIO m, MonadError String m)
                => AVPixelFormat -> InputSource
                -> m (IO (Maybe (AVFrame, Double)), IO ())
frameReaderTime :: AVPixelFormat
-> InputSource -> m (IO (Maybe (AVFrame, Double)), IO ())
frameReaderTime dstFmt :: AVPixelFormat
dstFmt src :: InputSource
src =
  do AVFormatContext
inputContext <- InputSource -> m AVFormatContext
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
InputSource -> m AVFormatContext
openInput InputSource
src
     AVFormatContext -> m ()
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext -> m ()
checkStreams AVFormatContext
inputContext
     (vidStreamIndex :: CInt
vidStreamIndex, ctx :: AVCodecContext
ctx, cod :: AVCodec
cod, vidStream :: AVStream
vidStream) <- AVFormatContext -> m (CInt, AVCodecContext, AVCodec, AVStream)
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext -> m (CInt, AVCodecContext, AVCodec, AVStream)
findVideoStream AVFormatContext
inputContext
     AVDictionary
_ <- AVCodecContext -> AVCodec -> m AVDictionary
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVCodecContext -> AVCodec -> m AVDictionary
openCodec AVCodecContext
ctx AVCodec
cod
     (reader :: IO (Maybe AVFrame)
reader, cleanup :: IO ()
cleanup) <- AVFormatContext
-> CInt
-> AVPixelFormat
-> AVCodecContext
-> m (IO (Maybe AVFrame), IO ())
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVFormatContext
-> CInt
-> AVPixelFormat
-> AVCodecContext
-> m (IO (Maybe AVFrame), IO ())
prepareReader AVFormatContext
inputContext CInt
vidStreamIndex AVPixelFormat
dstFmt AVCodecContext
ctx
     AVRational num :: CInt
num den :: CInt
den <- IO AVRational -> m AVRational
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AVRational -> m AVRational) -> IO AVRational -> m AVRational
forall a b. (a -> b) -> a -> b
$ AVStream -> IO AVRational
forall t. HasTimeBase t => t -> IO AVRational
getTimeBase AVStream
vidStream
     let (numl :: CLong
numl, dend :: Double
dend) = (CInt -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
num, CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
den)
         frameTime' :: t -> IO Double
frameTime' frame :: t
frame =
           do CLong
n <- t -> IO CLong
forall t. HasPts t => t -> IO CLong
getPts t
frame
              Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ CLong -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong
n CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
* CLong
numl) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dend
         readTS :: IO (Maybe (AVFrame, Double))
readTS = do Maybe AVFrame
frame <- IO (Maybe AVFrame)
reader
                     case Maybe AVFrame
frame of
                       Nothing -> Maybe (AVFrame, Double) -> IO (Maybe (AVFrame, Double))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AVFrame, Double)
forall a. Maybe a
Nothing
                       Just f :: AVFrame
f -> do Double
t <- AVFrame -> IO Double
forall t. HasPts t => t -> IO Double
frameTime' AVFrame
f
                                    Maybe (AVFrame, Double) -> IO (Maybe (AVFrame, Double))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AVFrame, Double) -> IO (Maybe (AVFrame, Double)))
-> Maybe (AVFrame, Double) -> IO (Maybe (AVFrame, Double))
forall a b. (a -> b) -> a -> b
$ (AVFrame, Double) -> Maybe (AVFrame, Double)
forall a. a -> Maybe a
Just (AVFrame
f, Double
t)
     (IO (Maybe (AVFrame, Double)), IO ())
-> m (IO (Maybe (AVFrame, Double)), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe (AVFrame, Double))
readTS, IO ()
cleanup)

-- | Read time stamped RGB frames with the result in the 'MaybeT'
-- transformer.
--
-- > frameReaderT = fmap (first MaybeT) . frameReader
frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m)
                 => InputSource -> m (MaybeT IO (AVFrame, Double), IO ())
frameReaderTimeT :: InputSource -> m (MaybeT IO (AVFrame, Double), IO ())
frameReaderTimeT = ((IO (Maybe (AVFrame, Double)), IO ())
 -> (MaybeT IO (AVFrame, Double), IO ()))
-> m (IO (Maybe (AVFrame, Double)), IO ())
-> m (MaybeT IO (AVFrame, Double), IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO (Maybe (AVFrame, Double)) -> MaybeT IO (AVFrame, Double))
-> (IO (Maybe (AVFrame, Double)), IO ())
-> (MaybeT IO (AVFrame, Double), IO ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first IO (Maybe (AVFrame, Double)) -> MaybeT IO (AVFrame, Double)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT) (m (IO (Maybe (AVFrame, Double)), IO ())
 -> m (MaybeT IO (AVFrame, Double), IO ()))
-> (InputSource -> m (IO (Maybe (AVFrame, Double)), IO ()))
-> InputSource
-> m (MaybeT IO (AVFrame, Double), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVPixelFormat
-> InputSource -> m (IO (Maybe (AVFrame, Double)), IO ())
forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
AVPixelFormat
-> InputSource -> m (IO (Maybe (AVFrame, Double)), IO ())
frameReaderTime AVPixelFormat
avPixFmtRgb24

-- | Construct an action that gets the next available frame, and an
-- action to release all resources associated with this video stream.
prepareReader :: (MonadIO m, MonadError String m)
              => AVFormatContext -> CInt -> AVPixelFormat -> AVCodecContext
              -> m (IO (Maybe AVFrame), IO ())
prepareReader :: AVFormatContext
-> CInt
-> AVPixelFormat
-> AVCodecContext
-> m (IO (Maybe AVFrame), IO ())
prepareReader fmtCtx :: AVFormatContext
fmtCtx vidStream :: CInt
vidStream dstFmt :: AVPixelFormat
dstFmt codCtx :: AVCodecContext
codCtx =
  IO (IO (Maybe AVFrame), IO ()) -> m (IO (Maybe AVFrame), IO ())
forall (m :: * -> *) a.
(MonadIO m, MonadError String m) =>
IO a -> m a
wrapIOError (IO (IO (Maybe AVFrame), IO ()) -> m (IO (Maybe AVFrame), IO ()))
-> IO (IO (Maybe AVFrame), IO ()) -> m (IO (Maybe AVFrame), IO ())
forall a b. (a -> b) -> a -> b
$
  do AVFrame
fRaw <- IO AVFrame
frame_alloc_check
     AVFrame
fRgb <- IO AVFrame
frame_alloc_check

     CInt
w <- AVCodecContext -> IO CInt
forall t. HasWidth t => t -> IO CInt
getWidth AVCodecContext
codCtx
     CInt
h <- AVCodecContext -> IO CInt
forall t. HasHeight t => t -> IO CInt
getHeight AVCodecContext
codCtx
     AVPixelFormat
fmt <- AVCodecContext -> IO AVPixelFormat
forall t. HasPixelFormat t => t -> IO AVPixelFormat
getPixelFormat AVCodecContext
codCtx

     AVFrame -> CInt -> IO ()
forall t. HasWidth t => t -> CInt -> IO ()
setWidth AVFrame
fRgb CInt
w
     AVFrame -> CInt -> IO ()
forall t. HasHeight t => t -> CInt -> IO ()
setHeight AVFrame
fRgb CInt
h
     AVFrame -> AVPixelFormat -> IO ()
forall t. HasPixelFormat t => t -> AVPixelFormat -> IO ()
setPixelFormat AVFrame
fRgb AVPixelFormat
dstFmt

     AVFrame -> CInt -> IO ()
frame_get_buffer_check AVFrame
fRgb 32

     SwsContext
sws <- ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsInit (CInt -> CInt -> AVPixelFormat -> ImageInfo
ImageInfo CInt
w CInt
h AVPixelFormat
fmt) (CInt -> CInt -> AVPixelFormat -> ImageInfo
ImageInfo CInt
w CInt
h AVPixelFormat
dstFmt) SwsAlgorithm
swsBilinear

     AVPacket
pkt <- Ptr () -> AVPacket
AVPacket (Ptr () -> AVPacket) -> IO (Ptr ()) -> IO AVPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (Ptr ())
forall a. Int -> IO (Ptr a)
mallocBytes Int
packetSize
     let cleanup :: IO ()
cleanup = do AVFrame -> (Ptr AVFrame -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with AVFrame
fRgb Ptr AVFrame -> IO ()
av_frame_free
                      AVFrame -> (Ptr AVFrame -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with AVFrame
fRaw Ptr AVFrame -> IO ()
av_frame_free
                      CInt
_ <- AVCodecContext -> IO CInt
codec_close AVCodecContext
codCtx
                      AVFormatContext -> (Ptr AVFormatContext -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with AVFormatContext
fmtCtx Ptr AVFormatContext -> IO ()
close_input
                      Ptr () -> IO ()
forall a. Ptr a -> IO ()
free (AVPacket -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVPacket
pkt)
         getFrame :: IO (Maybe AVFrame)
getFrame = do
           AVFormatContext -> AVPacket -> IO ()
read_frame_check AVFormatContext
fmtCtx AVPacket
pkt
           CInt
whichStream <- AVPacket -> IO CInt
forall t. HasStreamIndex t => t -> IO CInt
getStreamIndex AVPacket
pkt
           if CInt
whichStream CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
vidStream
           then do
             CInt
fin <- (Ptr CInt -> IO CInt) -> IO CInt
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO CInt) -> IO CInt)
-> (Ptr CInt -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \finished :: Ptr CInt
finished -> do
                      CInt
_ <- AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket -> IO CInt
decode_video AVCodecContext
codCtx AVFrame
fRaw Ptr CInt
finished AVPacket
pkt
                      Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
finished
             if CInt
fin CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> 0
             then do
               -- Some streaming codecs require a final flush with
               -- an empty packet
               -- fin' <- alloca $ \fin2 -> do
               --           free_packet pkt
               --           (#poke AVPacket, data) pkt nullPtr
               --           (#poke AVPacket, size) pkt (0::CInt)
               --           decode_video codCtx fRaw fin2 pkt
               --           peek fin2

               CInt
_ <- SwsContext -> AVFrame -> AVFrame -> IO CInt
forall src dst.
(SwsCompatible src, SwsCompatible dst) =>
SwsContext -> src -> dst -> IO CInt
swsScale SwsContext
sws AVFrame
fRaw AVFrame
fRgb

               -- Copy the raw frame's timestamp to the RGB frame
               AVFrame -> IO CLong
forall t. HasPktPts t => t -> IO CLong
getPktPts AVFrame
fRaw IO CLong -> (CLong -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVFrame -> CLong -> IO ()
forall t. HasPts t => t -> CLong -> IO ()
setPts AVFrame
fRgb

               AVPacket -> IO ()
free_packet AVPacket
pkt
               Maybe AVFrame -> IO (Maybe AVFrame)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AVFrame -> IO (Maybe AVFrame))
-> Maybe AVFrame -> IO (Maybe AVFrame)
forall a b. (a -> b) -> a -> b
$ AVFrame -> Maybe AVFrame
forall a. a -> Maybe a
Just AVFrame
fRgb
             else AVPacket -> IO ()
free_packet AVPacket
pkt IO () -> IO (Maybe AVFrame) -> IO (Maybe AVFrame)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe AVFrame)
getFrame
           else AVPacket -> IO ()
free_packet AVPacket
pkt IO () -> IO (Maybe AVFrame) -> IO (Maybe AVFrame)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe AVFrame)
getFrame
     (IO (Maybe AVFrame), IO ()) -> IO (IO (Maybe AVFrame), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe AVFrame)
getFrame IO (Maybe AVFrame)
-> (IOException -> IO (Maybe AVFrame)) -> IO (Maybe AVFrame)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` IO (Maybe AVFrame) -> IOException -> IO (Maybe AVFrame)
forall a b. a -> b -> a
const (Maybe AVFrame -> IO (Maybe AVFrame)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AVFrame
forall a. Maybe a
Nothing), IO ()
cleanup)