{-# LINE 1 "src/Codec/FFmpeg/Common.hsc" #-}
{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}
module Codec.FFmpeg.Common where
import Codec.FFmpeg.Enums
import Codec.FFmpeg.Types
import Control.Monad (when)
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Marshal.Alloc (allocaBytes)
import Control.Monad.Trans.Maybe

foreign import ccall "avcodec_open2"
  open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt

foreign import ccall "av_frame_alloc"
  av_frame_alloc :: IO AVFrame

foreign import ccall "av_frame_get_buffer"
  av_frame_get_buffer :: AVFrame -> CInt -> IO CInt

foreign import ccall "av_frame_free"
  av_frame_free :: Ptr AVFrame -> IO ()

foreign import ccall "avcodec_close"
  codec_close :: AVCodecContext -> IO CInt

foreign import ccall "av_init_packet"
  init_packet :: AVPacket -> IO ()

foreign import ccall "av_free_packet"
  free_packet :: AVPacket -> IO ()

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

foreign import ccall "av_free"
  av_free :: Ptr () -> IO ()

foreign import ccall "sws_getCachedContext"
  sws_getCachedContext :: SwsContext
                       -> CInt -> CInt -> AVPixelFormat
                       -> CInt -> CInt -> AVPixelFormat
                       -> SwsAlgorithm -> Ptr () -> Ptr () -> Ptr CDouble
                       -> IO SwsContext

foreign import ccall "sws_scale"
  sws_scale :: SwsContext
            -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt
            -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt

-- Return size of buffer for image.
foreign import ccall "av_image_get_buffer_size"
  av_image_get_buffer_size
    -- Pixel format.
    :: AVPixelFormat
    -- Width.
    -> CInt
    -- Height.
    -> CInt
    -- Line size alignment.
    -> CInt
    -- Size of buffer.
    -> IO CInt
    
-- Copy image to buffer.
foreign import ccall "av_image_copy_to_buffer"
  av_image_copy_to_buffer
    -- Destination buffer.
    :: Ptr CUChar
    -- Destination buffer size.
    -> CInt
    -- Source image data.
    -> Ptr (Ptr CUChar)
    -- Source image line size.
    -> Ptr CInt
    -- Source image pixel format.
    -> AVPixelFormat
    -- Source image width.
    -> CInt
    -- Source image height.
    -> CInt
    -- Source image line size alignment.
    -> CInt
    -- Number of bytes written to destination.
    -> IO CInt
    
    
-- * Utility functions

-- | Catch an IOException from an IO action and re-throw it in a
-- wrapping monad transformer.
wrapIOError :: (MonadIO m, MonadError String m) => IO a -> m a
wrapIOError :: IO a -> m a
wrapIOError io :: IO a
io = IO (Either String a) -> m (Either String a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a)
-> (IOException -> IO (Either String a)) -> IO (Either String a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ((a -> Either String a) -> IO a -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either String a
forall a b. b -> Either a b
Right IO a
io) (Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (IOException -> Either String a)
-> IOException
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (IOException -> String) -> IOException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show))
                 m (Either String a) -> (Either String a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- * Wrappers that may throw 'IOException's.

-- | Allocate an 'AVFrame' and set its fields to default values.
frame_alloc_check :: IO AVFrame
frame_alloc_check :: IO AVFrame
frame_alloc_check = do AVFrame
r <- IO AVFrame
av_frame_alloc
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AVFrame -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVFrame
r Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr)
                            (String -> IO ()
forall a. HasCallStack => String -> a
error "Couldn't allocate frame")
                       AVFrame -> IO AVFrame
forall (m :: * -> *) a. Monad m => a -> m a
return AVFrame
r

-- | Allocate new buffer(s) for audio or video data with the required
-- alignment. Note, for video frames, pixel format, @width@, and
-- @height@ must be set before calling this function. For audio
-- frames, sample @format@, @nb_samples@, and @channel_layout@ must be
-- set.
frame_get_buffer_check :: AVFrame -> CInt -> IO ()
frame_get_buffer_check :: AVFrame -> CInt -> IO ()
frame_get_buffer_check f :: AVFrame
f x :: CInt
x = do CInt
r <- AVFrame -> CInt -> IO CInt
av_frame_get_buffer AVFrame
f CInt
x
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
                                     (String -> IO ()
forall a. HasCallStack => String -> a
error "Failed to allocate buffers")

-- | Bytes-per-pixel for an 'AVPixelFormat'
avPixelStride :: AVPixelFormat -> Maybe Int
avPixelStride :: AVPixelFormat -> Maybe Int
avPixelStride fmt :: AVPixelFormat
fmt
  | AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtGray8  = Int -> Maybe Int
forall a. a -> Maybe a
Just 1
  | AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgb24  = Int -> Maybe Int
forall a. a -> Maybe a
Just 3
  | AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgba   = Int -> Maybe Int
forall a. a -> Maybe a
Just 4
  | AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgb8   = Int -> Maybe Int
forall a. a -> Maybe a
Just 1
  | AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtPal8   = Int -> Maybe Int
forall a. a -> Maybe a
Just 1
  | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
  
-- | Return line size alignment.
lineSizeAlign :: CInt -> CInt
lineSizeAlign :: CInt -> CInt
lineSizeAlign lineSize :: CInt
lineSize
  -- Alignment for 512 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 64 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 64
  -- Alignment for 256 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 32 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 32
  -- Alignment for 128 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 16 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 16
  -- Alignment for 64 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 8  CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 8
  -- Alignment for 32 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 4  CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 4
  -- Alignment for 16 bit register.
  | CInt
lineSize CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`mod` 2  CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 2
  -- Alignment for 8 bit register.
  | Bool
otherwise = 1

-- | Retun 'AVFrame's line size.
frameLineSize :: AVFrame -> IO (Maybe CInt)
frameLineSize :: AVFrame -> IO (Maybe CInt)
frameLineSize frame :: AVFrame
frame = do
  CInt
w   <- AVFrame -> IO CInt
forall t. HasWidth t => t -> IO CInt
getWidth AVFrame
frame
  AVPixelFormat
fmt <- AVFrame -> IO AVPixelFormat
forall t. HasPixelFormat t => t -> IO AVPixelFormat
getPixelFormat AVFrame
frame  
  Maybe CInt -> IO (Maybe CInt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CInt -> IO (Maybe CInt)) -> Maybe CInt -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$
    (CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
w) (CInt -> CInt) -> (Int -> CInt) -> Int -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Maybe Int -> Maybe CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AVPixelFormat -> Maybe Int
avPixelStride AVPixelFormat
fmt

-- | Transformer version of 'frameLineSize'.
frameLineSizeT :: AVFrame -> MaybeT IO CInt
frameLineSizeT :: AVFrame -> MaybeT IO CInt
frameLineSizeT = IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> (AVFrame -> IO (Maybe CInt)) -> AVFrame -> MaybeT IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> IO (Maybe CInt)
frameLineSize 

-- Return 'AVFrame's alignment.
frameAlign :: AVFrame -> IO (Maybe CInt)
frameAlign :: AVFrame -> IO (Maybe CInt)
frameAlign = (Maybe CInt -> Maybe CInt) -> IO (Maybe CInt) -> IO (Maybe CInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CInt -> CInt) -> Maybe CInt -> Maybe CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> CInt
lineSizeAlign) (IO (Maybe CInt) -> IO (Maybe CInt))
-> (AVFrame -> IO (Maybe CInt)) -> AVFrame -> IO (Maybe CInt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> IO (Maybe CInt)
frameLineSize 

-- Transformer version of 'frameAlign'.
frameAlignT :: AVFrame -> MaybeT IO CInt
frameAlignT :: AVFrame -> MaybeT IO CInt
frameAlignT = IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> (AVFrame -> IO (Maybe CInt)) -> AVFrame -> MaybeT IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> IO (Maybe CInt)
frameAlign


-- * Wrappers for copying 'AVFrame's image to buffer.    
        
-- | Return size of buffer for 'AVFrame's image.
frameBufferSize :: AVFrame -> IO (Maybe CInt)
frameBufferSize :: AVFrame -> IO (Maybe CInt)
frameBufferSize frame :: AVFrame
frame =
  MaybeT IO CInt -> IO (Maybe CInt)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO CInt -> IO (Maybe CInt))
-> MaybeT IO CInt -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ do
    CInt
a <- AVFrame -> MaybeT IO CInt
frameAlignT AVFrame
frame
    IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> IO (Maybe CInt) -> MaybeT IO CInt
forall a b. (a -> b) -> a -> b
$ do
      AVPixelFormat
fmt <- AVFrame -> IO AVPixelFormat
forall t. HasPixelFormat t => t -> IO AVPixelFormat
getPixelFormat AVFrame
frame
      CInt
w   <- AVFrame -> IO CInt
forall t. HasWidth t => t -> IO CInt
getWidth AVFrame
frame
      CInt
h   <- AVFrame -> IO CInt
forall t. HasHeight t => t -> IO CInt
getHeight AVFrame
frame
      CInt -> Maybe CInt
forall a. a -> Maybe a
Just (CInt -> Maybe CInt) -> IO CInt -> IO (Maybe CInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt
av_image_get_buffer_size AVPixelFormat
fmt CInt
w CInt
h CInt
a

-- | Transformer version of 'frameBufferSize'.
frameBufferSizeT :: AVFrame -> MaybeT IO CInt
frameBufferSizeT :: AVFrame -> MaybeT IO CInt
frameBufferSizeT = IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> (AVFrame -> IO (Maybe CInt)) -> AVFrame -> MaybeT IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> IO (Maybe CInt)
frameBufferSize

-- | Copy 'AVFrame's image to buffer.      
-- It is assumed that size of buffer is equal to
--
-- > bufSize <- fromJust <$> frameBufferSize frame.
frameCopyToBuffer :: AVFrame -> Ptr CUChar -> IO (Maybe CInt)
frameCopyToBuffer :: AVFrame -> Ptr CUChar -> IO (Maybe CInt)
frameCopyToBuffer frame :: AVFrame
frame buffer :: Ptr CUChar
buffer =
  MaybeT IO CInt -> IO (Maybe CInt)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO CInt -> IO (Maybe CInt))
-> MaybeT IO CInt -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ do
  
    CInt
a <- AVFrame -> MaybeT IO CInt
frameAlignT AVFrame
frame
    CInt
s <- AVFrame -> MaybeT IO CInt
frameBufferSizeT AVFrame
frame
    
    IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> IO (Maybe CInt) -> MaybeT IO CInt
forall a b. (a -> b) -> a -> b
$ do
        
      let imageData :: Ptr (Ptr ())
imageData = AVFrame -> Ptr (Ptr ())
forall t. HasData t => t -> Ptr (Ptr ())
hasData AVFrame
frame
          lineSize :: Ptr CInt
lineSize  = AVFrame -> Ptr CInt
forall t. HasLineSize t => t -> Ptr CInt
hasLineSize AVFrame
frame
      
      AVPixelFormat
fmt <- AVFrame -> IO AVPixelFormat
forall t. HasPixelFormat t => t -> IO AVPixelFormat
getPixelFormat AVFrame
frame
      CInt
w   <- AVFrame -> IO CInt
forall t. HasWidth t => t -> IO CInt
getWidth AVFrame
frame
      CInt
h   <- AVFrame -> IO CInt
forall t. HasHeight t => t -> IO CInt
getHeight AVFrame
frame

      CInt -> Maybe CInt
forall a. a -> Maybe a
Just (CInt -> Maybe CInt) -> IO CInt -> IO (Maybe CInt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Ptr CUChar
-> CInt
-> Ptr (Ptr CUChar)
-> Ptr CInt
-> AVPixelFormat
-> CInt
-> CInt
-> CInt
-> IO CInt
av_image_copy_to_buffer
          Ptr CUChar
buffer
          CInt
s
          (Ptr (Ptr ()) -> Ptr (Ptr CUChar)
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr ())
imageData)
          Ptr CInt
lineSize
          AVPixelFormat
fmt
          CInt
w
          CInt
h
          CInt
a

-- | Transformer version of 'frameCopyToBuffer'.
frameCopyToBufferT :: AVFrame -> Ptr CUChar -> MaybeT IO CInt
frameCopyToBufferT :: AVFrame -> Ptr CUChar -> MaybeT IO CInt
frameCopyToBufferT frame :: AVFrame
frame = IO (Maybe CInt) -> MaybeT IO CInt
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe CInt) -> MaybeT IO CInt)
-> (Ptr CUChar -> IO (Maybe CInt)) -> Ptr CUChar -> MaybeT IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AVFrame -> Ptr CUChar -> IO (Maybe CInt)
frameCopyToBuffer AVFrame
frame

-- * FFmpeg Errors

foreign import ccall "av_strerror"
  av_strerror :: CInt -> Ptr CChar -> CSize -> IO CInt

stringError :: CInt -> IO String
stringError :: CInt -> IO String
stringError err :: CInt
err =
  Int -> (Ptr Any -> IO String) -> IO String
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
len ((Ptr Any -> IO String) -> IO String)
-> (Ptr Any -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \block :: Ptr Any
block -> do
    let buf :: Ptr b
buf = Ptr Any -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
block
    CInt
_ <- CInt -> Ptr CChar -> CSize -> IO CInt
av_strerror CInt
err Ptr CChar
forall a. Ptr a
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    Ptr CChar -> IO String
peekCString Ptr CChar
forall a. Ptr a
buf
  where
    len :: Int
len = 1000