packages feed

ffmpeg-light (empty) → 0.1.0.0

raw patch · 12 files changed

+1133/−0 lines, 12 filesdep +JuicyPixelsdep +basedep +mtlsetup-changed

Dependencies added: JuicyPixels, base, mtl, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Anthony Cowley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anthony Cowley nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ffmpeg-light.cabal view
@@ -0,0 +1,51 @@+name:                ffmpeg-light+version:             0.1.0.0+synopsis:            Minimal bindings to the FFmpeg library.++description:         Stream frames from an encoded video, or stream frames to+                     a video output file. To read the first frame from+                     an @h264@-encoded file into a JuicyPixels +                     @Maybe DynamicImage@,+                     .+                     > import Codec.FFmpeg+                     > import Codec.Picture+                     > import Control.Applicative+                     > import Data.Traversable+                     >+                     > go :: IO (Maybe DynamicImage)+                     > go = do (getFrame, cleanup) <- frameReader "myVideo.mov"+                     >         (getFrame >>= traverse juicyRGB) <* cleanup+                     .+                     Tested on OS X 10.9.2 with <http://www.ffmpeg.org FFmpeg> 2.2.1+                     installed via <http://brew.sh homebrew>.++license:             BSD3+license-file:        LICENSE+author:              Anthony Cowley+maintainer:          acowley@gmail.com+copyright:           Copyright (C) 2014 Anthony Cowley+category:            Codec+build-type:          Simple+extra-source-files:  src/hscMacros.h+cabal-version:       >=1.10++library+  exposed-modules:     Codec.FFmpeg,+                       Codec.FFmpeg.Common,+                       Codec.FFmpeg.Decode,+                       Codec.FFmpeg.Encode,+                       Codec.FFmpeg.Enums,+                       Codec.FFmpeg.Juicy,+                       Codec.FFmpeg.Types,+                       Codec.FFmpeg.Internal.Debug+  build-tools:         hsc2hs+  build-depends:       base >=4.6 && < 5, +                       vector >= 0.10.9 && < 0.11,+                       transformers >= 0.3 && < 0.4,+                       mtl >= 2.1.3 && < 2.2,+                       JuicyPixels >= 3.1 && < 3.2+  pkgconfig-depends:   libavutil, libavformat, libavcodec, libswscale+  hs-source-dirs:      src+  include-dirs:        src+  default-language:    Haskell2010+  ghc-options:         -Wall
+ src/Codec/FFmpeg.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts #-}+-- | Interface to initialize FFmpeg, decode video files, encode video+-- files, and convert decoded image frames to JuicyPixels images.+module Codec.FFmpeg (-- * Initialization+                     initFFmpeg, +                     -- * Decoding+                     frameReader, frameReaderTime,+                     -- * Encoding+                     EncodingParams(..), defaultParams, frameWriter,+                     -- * JuicyPixels interop+                     juicyRGB, saveJuicyRGB,+                     -- * Types and Enums+                     module Codec.FFmpeg.Types, +                     module Codec.FFmpeg.Enums+                     )where+import Codec.FFmpeg.Decode+import Codec.FFmpeg.Encode+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Juicy+import Codec.FFmpeg.Types++foreign import ccall "av_register_all" av_register_all :: IO ()++-- foreign import ccall "avcodec_register_all" avcodec_register_all :: IO ()++-- | Initialize FFmpeg by registering all known codecs. This /must/+-- be called before using other FFmpeg functions.+initFFmpeg :: IO ()+initFFmpeg = av_register_all+
+ src/Codec/FFmpeg/Common.hsc view
@@ -0,0 +1,75 @@+{-# 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.Types+import Foreign.Ptr++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_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++-- * Utility functions++-- | Catch an IOException from an IO action and re-throw it in a+-- wrapping monad transformer.+wrapIOError :: (MonadIO m, Error e, MonadError e m) => IO a -> m a+wrapIOError = liftIO . flip catchError (errMsg . show)++-- | Throw an error with a 'String' message.+errMsg :: (Error e, MonadError e m) => String -> m a+errMsg = throwError . strMsg++-- * Wrappers that may throw 'IOException's.++-- | Allocate an 'AVFrame' and set its fields to default values.+frame_alloc_check :: IO AVFrame+frame_alloc_check = do r <- av_frame_alloc+                       when (getPtr r == nullPtr)+                            (errMsg "Couldn't allocate frame")+                       return 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 f x = do r <- av_frame_get_buffer f x+                                when (r /= 0)+                                     (errMsg "Failed to allocate buffers")
+ src/Codec/FFmpeg/Decode.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts #-}+-- | 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.Types+import Control.Applicative+import Control.Monad (when)+import Control.Monad.Error.Class+import Control.Monad.IO.Class+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 ()+                      -> Ptr (Ptr ()) -> 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 "avcodec_get_frame_defaults"+  avcodec_get_frame_defaults :: AVFrame -> IO ()++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 ()++-- * FFmpeg Decoding Interface++-- | Open an input media file.+openInput :: (MonadIO m, Error e, MonadError e m) => String -> m AVFormatContext+openInput filename = +  wrapIOError . alloca $ \ctx ->+    withCString filename $ \cstr ->+      do r <- avformat_open_input ctx cstr nullPtr nullPtr+         when (r /= 0) (errMsg "Error opening file")+         peek ctx++-- | @AVFrame@ is a superset of @AVPicture@, so we can upcast an+-- 'AVFrame' to an 'AVPicture'.+frameAsPicture :: AVFrame -> AVPicture+frameAsPicture = AVPicture . getPtr++-- | Find a codec given by name.+findDecoder :: (MonadIO m, Error e, MonadError e m) => String -> m AVCodec+findDecoder name = +  do r <- liftIO $ withCString name avcodec_find_decoder_by_name+     when (getPtr r == nullPtr)+          (errMsg $ "Unsupported codec: " ++ show name)+     return 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, Error e, MonadError e m) => AVFormatContext -> m ()+checkStreams ctx = +  do r <- liftIO $ avformat_find_stream_info ctx nullPtr+     when (r < 0) (errMsg "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, Error e, MonadError e m)+                => AVFormatContext -> m (CInt, AVCodecContext, AVCodec)+findVideoStream fmt = do+  wrapIOError . alloca $ \codec -> do+      poke codec (AVCodec nullPtr)+      i <- av_find_best_stream fmt avmediaTypeVideo (-1) (-1) codec 0+      when (i < 0) (errMsg "Couldn't find a video stream")+      cod <- peek codec+      streams <- getStreams fmt+      vidStream <- peek (advancePtr streams (fromIntegral i))+      ctx <- getCodecContext vidStream+      return (i, ctx, cod)++-- | Find a registered decoder with a codec ID matching that found in+-- the given 'AVCodecContext'.+getDecoder :: (MonadIO m, Error e, MonadError e m)+           => AVCodecContext -> m AVCodec+getDecoder ctx = do p <- liftIO $ getCodecID ctx >>= avcodec_find_decoder+                    when (getPtr p == nullPtr) (errMsg "Unsupported codec")+                    return p++-- | Initialize the given 'AVCodecContext' to use the given+-- 'AVCodec'. **NOTE**: This function is not thread safe!+openCodec :: (MonadIO m, Error e, MonadError e m)+          => AVCodecContext -> AVCodec -> m AVDictionary+openCodec ctx cod = +  wrapIOError . alloca $ \dict -> do+    poke dict (AVDictionary nullPtr)+    r <- open_codec ctx cod dict+    when (r < 0) (errMsg "Couldn't open decoder")+    peek dict++-- | Return the next frame of a stream.+read_frame_check :: AVFormatContext -> AVPacket -> IO ()+read_frame_check ctx pkt = do r <- av_read_frame ctx pkt+                              when (r < 0) (errMsg "Frame read failed")++-- | Read RGB frames from a video stream.+frameReader :: (MonadIO m, Error e, MonadError e m)+            => FilePath -> m (IO (Maybe AVFrame), IO ())+frameReader fileName =+  do inputContext <- openInput fileName+     checkStreams inputContext+     (vidStreamIndex, ctx, cod) <- findVideoStream inputContext+     _ <- openCodec ctx cod+     prepareReader inputContext vidStreamIndex ctx++-- | Read time stamped RGB frames from a video stream. Time is given+-- in seconds from the start of the stream.+frameReaderTime :: (MonadIO m, Error e, MonadError e m)+                => FilePath -> m (IO (Maybe (AVFrame, Double)), IO ())+frameReaderTime fileName =+  do inputContext <- openInput fileName+     checkStreams inputContext+     (vidStreamIndex, ctx, cod) <- findVideoStream inputContext+     _ <- openCodec ctx cod+     (reader, cleanup) <- prepareReader inputContext vidStreamIndex ctx+     AVRational num den <- liftIO $ getTimeBase ctx+     let (numl, dend) = (fromIntegral num, fromIntegral den)+         frameTime' frame = +           do n <- getPts frame+              return $ fromIntegral (n * numl) / dend+         readTS = do frame <- reader+                     case frame of+                       Nothing -> return Nothing+                       Just f -> do t <- frameTime' f+                                    return $ Just (f, t)+     return (readTS, cleanup)++-- | Construct an action that gets the next available frame, and an+-- action to release all resources associated with this video stream.+prepareReader :: (MonadIO m, Error e, MonadError e m)+              => AVFormatContext -> CInt -> AVCodecContext+              -> m (IO (Maybe AVFrame), IO ())+prepareReader fmtCtx vidStream codCtx =+  wrapIOError $+  do fRaw <- frame_alloc_check+     fRgb <- frame_alloc_check++     w <- getWidth codCtx+     h <- getHeight codCtx+     fmt <- getPixelFormat codCtx++     setWidth fRgb w+     setHeight fRgb h+     setPixelFormat fRgb avPixFmtRgb24++     frame_get_buffer_check fRgb 32++     sws <- sws_getCachedContext (SwsContext nullPtr) +              w h fmt+              w h avPixFmtRgb24+              swsBilinear+              nullPtr nullPtr nullPtr++     pkt <- AVPacket <$> mallocBytes packetSize+     let cleanup = do with fRgb av_frame_free+                      with fRaw av_frame_free+                      _ <- codec_close codCtx+                      with fmtCtx close_input+                      free (getPtr pkt)+         getFrame = do+           read_frame_check fmtCtx pkt+           whichStream <- getStreamIndex pkt+           if whichStream == vidStream+           then do+             fin <- alloca $ \finished -> do+                      _ <- decode_video codCtx fRaw finished pkt+                      peek finished+             if fin > 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+               let frameData = castPtr $ hasData fRaw+                   lnSize = hasLineSize fRaw+                   rgbData = castPtr $ hasData fRgb+                   rgbLnSize = hasLineSize fRgb++               _ <- sws_scale sws frameData lnSize 0 h rgbData rgbLnSize++               -- Copy the raw frame's timestamp to the RGB frame+               getPktPts fRaw >>= setPts fRgb++               free_packet pkt+               return $ Just fRgb+             else free_packet pkt >> getFrame+           else free_packet pkt >> getFrame+     return (getFrame `catchError` const (return Nothing), cleanup)
+ src/Codec/FFmpeg/Encode.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- | Video encoding 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.Encode where+import Codec.FFmpeg.Common+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Types+import Control.Applicative+import Control.Monad (when)+import Control.Monad.Error.Class+import Data.Bits+import Data.Maybe (fromMaybe)+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as V+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Utils++import Foreign.Ptr+import Foreign.Storable++-- Based on the FFmpeg muxing example+-- http://www.ffmpeg.org/doxygen/2.1/doc_2examples_2muxing_8c-example.html++-- * FFI Declarations++foreign import ccall "avcodec_find_encoder"+  avcodec_find_encoder :: AVCodecID -> IO AVCodec++foreign import ccall "avcodec_find_encoder_by_name"+  avcodec_find_encoder_by_name :: CString -> IO AVCodec++foreign import ccall "av_opt_set"+  av_opt_set :: Ptr () -> CString -> CString -> CInt -> IO CInt++foreign import ccall "avcodec_encode_video2"+  avcodec_encode_video2 :: AVCodecContext -> AVPacket -> AVFrame -> Ptr CInt+                        -> IO CInt++foreign import ccall "av_image_alloc"+  av_image_alloc :: Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt+                 -> AVPixelFormat -> CInt -> IO CInt++foreign import ccall "av_freep"+  av_freep :: Ptr (Ptr a) -> IO ()++foreign import ccall "av_guess_format"+  guess_format :: CString -> CString -> CString -> IO AVOutputFormat++foreign import ccall "avformat_alloc_output_context2"+  avformat_alloc_output_context :: Ptr AVFormatContext -> AVOutputFormat+                                -> CString -> CString -> IO CInt++foreign import ccall "avformat_new_stream"+  avformat_new_stream :: AVFormatContext -> AVCodec -> IO AVStream++foreign import ccall "av_write_frame"+  av_write_frame :: AVFormatContext -> AVPacket -> IO CInt++foreign import ccall "av_interleaved_write_frame"+  av_interleaved_write_frame :: AVFormatContext -> AVPacket -> IO CInt++foreign import ccall "avformat_write_header"+  avformat_write_header :: AVFormatContext -> Ptr AVDictionary -> IO CInt++foreign import ccall "av_write_trailer"+  av_write_trailer :: AVFormatContext -> IO CInt++foreign import ccall "avio_open"+  avio_open :: Ptr AVIOContext -> CString -> AVIOFlag -> IO CInt++foreign import ccall "avio_close"+  avio_close :: AVIOContext -> IO CInt++foreign import ccall "avformat_free_context"+  avformat_free_context :: AVFormatContext -> IO ()++-- * FFmpeg Encoding Interface++-- | Minimal parameters describing the desired video output.+data EncodingParams = EncodingParams { epWidth  :: CInt+                                     , epHeight :: CInt+                                     , epFps    :: Int+                                     , epCodec  :: AVCodecID+                                     , epPreset :: String }++-- | Use default parameters for a video of the given width and+-- height. This produces an h264 encoded stream.+defaultParams :: CInt -> CInt -> EncodingParams+defaultParams w h = EncodingParams w h 30 avCodecIdH264 "medium"++-- | Find and initialize the requested encoder, and add a video stream+-- to the output container.+initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext)+initStream ep _+  | (epWidth ep `rem` 2, epHeight ep `rem` 2) /= (0,0) =+    throwError $ strMsg "Video dimensions must be multiples of two"+initStream ep oc = do+  cod <- avcodec_find_encoder (epCodec ep)+  when (getPtr cod == nullPtr)+       (throwError $ strMsg "Couldn't find H264 encoder")++  st <- avformat_new_stream oc cod+  getNumStreams oc >>= setId st . subtract 1++  ctx <- getCodecContext st+  setWidth ctx (epWidth ep)+  setHeight ctx (epHeight ep)+  let framePeriod = AVRational 1 (fromIntegral $ epFps ep)+  setTimeBase ctx framePeriod+  setPixelFormat ctx avPixFmtYuv420p+  +  -- Some formats want stream headers to be separate+  outputFlags <- getOutputFormat oc >>= getFormatFlags+  when (outputFlags .&. avfmtGlobalheader /= clearBit (bit 0) 0) $+    getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader)++  -- _ <- withCString "vprofile" $ \kStr ->+  --        withCString (preset ep) $ \vStr ->+  --          av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx))+  --                     kStr vStr 0+  -- _ <- withCString "preset" $ \kStr ->+  --        withCString "medium" $ \vStr ->+  --          av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx))+  --                     kStr vStr 0++  rOpen <- open_codec ctx cod nullPtr+  when (rOpen < 0) (throwError $ strMsg "Couldn't open codec")+  return (st, ctx)++-- | Initialize a temporary YUV frame of the same resolution as the+-- output video stream. We well convert RGB frames using this frame as+-- a destination before encoding the video frame.+initTempYuv :: EncodingParams -> IO AVFrame+initTempYuv ep = do+  yuv <- frame_alloc_check+  setPixelFormat yuv avPixFmtYuv420p+  setWidth yuv (epWidth ep)+  setHeight yuv (epHeight ep)+  setPts yuv 0+  frame_get_buffer_check yuv 32+  return yuv++-- | Allocate an output context inferring the codec from the given+-- file name.+allocOutputContext :: FilePath -> IO AVFormatContext+allocOutputContext fname = do+  oc <- alloca $ \ocTmp ->+          withCString fname $ \fname' -> do+            r <- avformat_alloc_output_context ocTmp (AVOutputFormat nullPtr)+                                               nullPtr fname'+            when (r < 0)+                 (throwError $ strMsg "Couldn't allocate output format context")+            peek ocTmp+  when (getPtr oc == nullPtr)+       (throwError $ strMsg "Couldn't allocate output AVFormatContext")+  return oc++-- | Open the given file for writing.+avio_open_check :: AVFormatContext -> String -> IO ()+avio_open_check oc fname =+  do r <- withCString fname $ \cstr ->+            avio_open (hasIOContext oc) cstr avioFlagWrite+     when (r < 0) (errMsg "Error opening IO for writing")++-- | Close an open IO context.+avio_close_check :: AVFormatContext -> IO ()+avio_close_check oc = do r <- getIOContext oc >>= avio_close+                         when (r /= 0) (errMsg "Error closing IO")++-- | Returns 'True' if the 'AVPacket' was updated with new output+-- data; 'False' otherwise.+encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool+encode_video_check ctx pkt frame =+  alloca $ \gotOutput -> do+    r <- avcodec_encode_video2 ctx pkt frame' gotOutput+    when (r < 0) (errMsg "Error encoding frame")+    (> 0) <$> peek gotOutput+  where frame' = fromMaybe (AVFrame nullPtr) frame++-- | Allocate the stream private data and write the stream header to+-- an output media file.+write_header_check :: AVFormatContext -> IO ()+write_header_check oc = do r <- avformat_write_header oc nullPtr+                           when (r < 0) (errMsg "Error writing header")++-- | Write a packet to an output media file.+write_frame_check :: AVFormatContext -> AVPacket -> IO ()+write_frame_check oc pkt = do r <- av_write_frame oc pkt+                              when (r < 0) (errMsg "Error writing frame")++-- | Write the stream trailer to an output media file and free the+-- private data. May only be called after a successful call to+-- 'write_header_check'.+write_trailer_check :: AVFormatContext -> IO ()+write_trailer_check oc = do r <- av_write_trailer oc+                            when (r /= 0) (errMsg "Error writing trailer")++-- | Open a target file for writing a video stream. The function+-- returned may be used to write RGB images of the resolution given by+-- the provided 'EncodingParams'. The function will convert the+-- supplied RGB frame to YUV (specifically, @yuv420p@) before encoding+-- the image to the video stream. If this function is applied to+-- 'Nothing', then the output stream is closed. Note that 'Nothing'+-- /must/ be provided to properly terminate video encoding.+frameWriter :: EncodingParams -> FilePath -> IO (Maybe (Vector CUChar) -> IO ())+frameWriter ep fname = do+  oc <- allocOutputContext fname+  (st,ctx) <- initStream ep oc++  yuv <- initTempYuv ep++  sws <- sws_getCachedContext (SwsContext nullPtr)+           (epWidth ep) (epHeight ep) avPixFmtRgb24+           (epWidth ep) (epHeight ep) avPixFmtYuv420p+           swsBilinear nullPtr nullPtr nullPtr++  pkt <- AVPacket <$> mallocBytes packetSize++  stIndex <- getStreamIndex st+  avio_open_check oc fname+  write_header_check oc++  tb <- getTimeBase st+  codecTB <- getCodecContext st >>= getTimeBase+  let frameTime = av_rescale_q 1 codecTB tb++  let resetPacket = do init_packet pkt+                       setData pkt nullPtr+                       setSize pkt 0+      writePacket = do setStreamIndex pkt stIndex+                       write_frame_check oc pkt+      go Nothing = do+        resetPacket+        goOn <- encode_video_check ctx pkt Nothing+        if goOn+        then writePacket >> go Nothing+        else do write_trailer_check oc+                _ <- codec_close ctx+                with yuv av_frame_free+                avio_close_check oc+                avformat_free_context oc++      go (Just pixels) = do+        resetPacket+        let yuvData = castPtr $ hasData yuv+            yuvStride = hasLineSize yuv++        _ <- V.unsafeWith pixels $ \pixelPtr ->+               withArray (pixelPtr : replicate 7 nullPtr) $ \srcArray ->+                 withArray (epWidth ep * 3 : replicate 7 0) $ \strides ->+                   sws_scale sws srcArray strides 0 (epHeight ep) +                             yuvData yuvStride++        getPts yuv >>= setPts yuv . (+ frameTime)+        encode_video_check ctx pkt (Just yuv) >>= flip when writePacket+  return go
+ src/Codec/FFmpeg/Enums.hsc view
@@ -0,0 +1,192 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Codec.FFmpeg.Enums where+import Data.Bits (Bits)+import Foreign.C.Types+import Foreign.Storable (Storable)++#include <libavcodec/avcodec.h>+#include <libavformat/avformat.h>+#include <libavutil/avutil.h>+#include <libswscale/swscale.h>++newtype AVMediaType = AVMediaType CInt deriving (Eq, Storable)+#enum AVMediaType,AVMediaType \+ , AVMEDIA_TYPE_VIDEO\+ , AVMEDIA_TYPE_AUDIO\+ , AVMEDIA_TYPE_DATA\+ , AVMEDIA_TYPE_SUBTITLE\+ , AVMEDIA_TYPE_ATTACHMENT\+ , AVMEDIA_TYPE_NB++newtype AVPixelFormat = AVPixelFormat CInt deriving (Eq, Storable)+#enum AVPixelFormat,AVPixelFormat \+ , AV_PIX_FMT_RGB24\+ , AV_PIX_FMT_Y400A\+ , AV_PIX_FMT_RGB32\+ , AV_PIX_FMT_RGB32_1\+ , AV_PIX_FMT_BGR32\+ , AV_PIX_FMT_BGR32_1\+ , AV_PIX_FMT_GRAY8\+ , AV_PIX_FMT_GRAY16\+ , AV_PIX_FMT_GRAY8A\+ , AV_PIX_FMT_RGB565\+ , AV_PIX_FMT_RGB555\+ , AV_PIX_FMT_YUV420P\+ , AV_PIX_FMT_YUV420P9\+ , AV_PIX_FMT_YUV420P10\+ , AV_PIX_FMT_YUV420P12\+ , AV_PIX_FMT_YUV422P12\+ , AV_PIX_FMT_YUV444P12\+ , AV_PIX_FMT_YUV420P14\+ , AV_PIX_FMT_YUV422P14\+ , AV_PIX_FMT_YUV444P14\+ , AV_PIX_FMT_YUV420P16\+ , AV_PIX_FMT_YUV422P16\+ , AV_PIX_FMT_YUV444P16\+ , AV_PIX_FMT_RGBA64\+ , AV_PIX_FMT_BGRA64++instance Show AVPixelFormat where+  show x+    | x == avPixFmtRgb24 = "AV_PIX_FMT_RGB24"+    | x == avPixFmtYuv420p = "AV_PIX_FMT_Y420P"+    | x == avPixFmtYuv422p12 = "AV_PIX_FMTYUV422P12"+    | x == avPixFmtYuv420p14 = "AV_PIX_FMTYUV422P12"+    | otherwise = let AVPixelFormat y = x+                  in "Other pixel format: "++show y++newtype AVCodecID = AVCodecID CInt deriving (Eq, Show, Storable)+#enum AVCodecID,AVCodecID \+ , AV_CODEC_ID_H264\+ , AV_CODEC_ID_THEORA\+ , AV_CODEC_ID_MPEG4\+ , AV_CODEC_ID_MPEG2VIDEO\+ , AV_CODEC_ID_GIF\+ , AV_CODEC_ID_AAC\+ , AV_CODEC_ID_MP3\+ , AV_CODEC_ID_DTS++newtype SwsAlgorithm = SwsAlgorithm CUInt deriving (Eq, Show, Storable)+#enum SwsAlgorithm,SwsAlgorithm \+ , SWS_FAST_BILINEAR\+ , SWS_BILINEAR\+ , SWS_BICUBIC\+ , SWS_X\+ , SWS_POINT\+ , SWS_AREA\+ , SWS_BICUBLIN\+ , SWS_GAUSS\+ , SWS_SINC\+ , SWS_LANCZOS\+ , SWS_SPLINE++newtype FFProfile = FFProfile CInt deriving (Eq, Storable)+#enum FFProfile, FFProfile \+ , FF_PROFILE_AAC_MAIN\+ , FF_PROFILE_AAC_LOW\+ , FF_PROFILE_AAC_SSR\+ , FF_PROFILE_AAC_LTP\+ , FF_PROFILE_AAC_HE\+ , FF_PROFILE_AAC_HE_V2\+ , FF_PROFILE_AAC_LD\+ , FF_PROFILE_AAC_ELD\+ , FF_PROFILE_MPEG2_AAC_LOW\+ , FF_PROFILE_MPEG2_AAC_HE\+ , FF_PROFILE_DTS\+ , FF_PROFILE_DTS_ES\+ , FF_PROFILE_DTS_96_24\+ , FF_PROFILE_DTS_HD_HRA\+ , FF_PROFILE_DTS_HD_MA\+ , FF_PROFILE_MPEG2_422\+ , FF_PROFILE_MPEG2_HIGH\+ , FF_PROFILE_MPEG2_SS\+ , FF_PROFILE_MPEG2_SNR_SCALABLE\+ , FF_PROFILE_MPEG2_MAIN\+ , FF_PROFILE_MPEG2_SIMPLE\+ , FF_PROFILE_H264_CONSTRAINED\+ , FF_PROFILE_H264_INTRA\+ , FF_PROFILE_H264_BASELINE\+ , FF_PROFILE_H264_CONSTRAINED_BASELINE\+ , FF_PROFILE_H264_MAIN\+ , FF_PROFILE_H264_EXTENDED\+ , FF_PROFILE_H264_HIGH\+ , FF_PROFILE_H264_HIGH_10\+ , FF_PROFILE_H264_HIGH_10_INTRA\+ , FF_PROFILE_H264_HIGH_422\+ , FF_PROFILE_H264_HIGH_422_INTRA\+ , FF_PROFILE_H264_HIGH_444\+ , FF_PROFILE_H264_HIGH_444_PREDICTIVE\+ , FF_PROFILE_H264_HIGH_444_INTRA\+ , FF_PROFILE_H264_CAVLC_444\+ , FF_PROFILE_VC1_SIMPLE\+ , FF_PROFILE_VC1_MAIN\+ , FF_PROFILE_VC1_COMPLEX\+ , FF_PROFILE_VC1_ADVANCED\+ , FF_PROFILE_MPEG4_SIMPLE\+ , FF_PROFILE_MPEG4_SIMPLE_SCALABLE\+ , FF_PROFILE_MPEG4_CORE\+ , FF_PROFILE_MPEG4_MAIN\+ , FF_PROFILE_MPEG4_N_BIT\+ , FF_PROFILE_MPEG4_SCALABLE_TEXTURE\+ , FF_PROFILE_MPEG4_SIMPLE_FACE_ANIMATION\+ , FF_PROFILE_MPEG4_BASIC_ANIMATED_TEXTURE\+ , FF_PROFILE_MPEG4_HYBRID\+ , FF_PROFILE_MPEG4_ADVANCED_REAL_TIME\+ , FF_PROFILE_MPEG4_CORE_SCALABLE\+ , FF_PROFILE_MPEG4_ADVANCED_CODING\+ , FF_PROFILE_MPEG4_ADVANCED_CORE\+ , FF_PROFILE_MPEG4_ADVANCED_SCALABLE_TEXTURE\+ , FF_PROFILE_MPEG4_SIMPLE_STUDIO\+ , FF_PROFILE_MPEG4_ADVANCED_SIMPLE++newtype AVIOFlag = AVIOFlag CInt deriving (Eq, Storable)+#enum AVIOFlag, AVIOFlag \+ , AVIO_FLAG_READ\+ , AVIO_FLAG_WRITE\+ , AVIO_FLAG_READ_WRITE\+ , AVIO_FLAG_NONBLOCK\+ , AVIO_FLAG_DIRECT++newtype AVRoundMode = AVRoundMode CInt deriving (Eq, Storable)+#enum AVRoundMode, AVRoundMode \+ , AV_ROUND_NEAR_INF\+ , AV_ROUND_PASS_MINMAX++newtype CodecFlag = CodecFlag CInt deriving (Eq, Bits, Storable)+#enum CodecFlag, CodecFlag \+ , CODEC_FLAG_UNALIGNED\+ , CODEC_FLAG_QSCALE\+ , CODEC_FLAG_4MV\+ , CODEC_FLAG_OUTPUT_CORRUPT\+ , CODEC_FLAG_QPEL\+ , CODEC_FLAG_GMC\+ , CODEC_FLAG_MV0\+ , CODEC_FLAG_INPUT_PRESERVED\+ , CODEC_FLAG_PASS1\+ , CODEC_FLAG_PASS2\+ , CODEC_FLAG_GRAY\+ , CODEC_FLAG_EMU_EDGE\+ , CODEC_FLAG_PSNR\+ , CODEC_FLAG_TRUNCATED\+ , CODEC_FLAG_NORMALIZE_AQP\+ , CODEC_FLAG_INTERLACED_DCT\+ , CODEC_FLAG_LOW_DELAY\+ , CODEC_FLAG_GLOBAL_HEADER\+ , CODEC_FLAG_BITEXACT\+ , CODEC_FLAG_AC_PRED\+ , CODEC_FLAG_LOOP_FILTER\+ , CODEC_FLAG_INTERLACED_ME\+ , CODEC_FLAG_CLOSED_GOP++newtype FormatFlag = FormatFlag CInt deriving (Eq, Bits, Storable)+#enum FormatFlag, FormatFlag \+ , AVFMT_NOFILE\+ , AVFMT_NEEDNUMBER\+ , AVFMT_RAWPICTURE\+ , AVFMT_GLOBALHEADER\+ , AVFMT_NOTIMESTAMPS\+ , AVFMT_VARIABLE_FPS\+ , AVFMT_NODIMENSIONS\+ , AVFMT_NOSTREAMS\+ , AVFMT_ALLOW_FLUSH\+ , AVFMT_TS_NONSTRICT
+ src/Codec/FFmpeg/Internal/Debug.hsc view
@@ -0,0 +1,41 @@+-- | Helpers for dumping information about codecs to stdout.+module Codec.FFmpeg.Internal.Debug where+import Codec.FFmpeg.Types+import Foreign.C.String+import Foreign.C.Types+import Foreign.Storable++#include <libavcodec/avcodec.h>+#include <libavformat/avformat.h>++-- | FFmpeg's built-in format debug utlity.+foreign import ccall "av_dump_format"+  av_dump_format :: AVFormatContext -> CInt -> CString -> CInt -> IO ()++-- | Print the short name, long name, and ID of a codec.+debugCodec :: AVCodec -> IO ()+debugCodec cod = do+  longName <- getLongName cod >>= peekCString+  shortName <- getName cod >>= peekCString+  cid <- getCodecID cod+  putStrLn $ "Codec short_name = " ++ show shortName+  putStrLn $ "Codec long_name = " ++ show longName+  putStrLn $ "Codec ID = " ++ show cid++-- | Print various codec settings.+debugCodecContext :: AVCodecContext -> IO()+debugCodecContext (AVCodecContext p) = do+  putStrLn "*** AVCodecContext dump:"+  (#peek AVCodecContext, profile) p >>= si "profile"+  (#peek AVCodecContext, flags) p >>= si "flags"+  (#peek AVCodecContext, flags2) p >>= si "flags2"+  (#peek AVCodecContext, gop_size) p >>= si "gop_size"+  (#peek AVCodecContext, bit_rate) p >>= si "bit_rate"+  (#peek AVCodecContext, max_b_frames) p >>= si "max_b_frames"+  (#peek AVCodecContext, b_frame_strategy) p >>= si "b_frame_strategy"+  (#peek AVCodecContext, qmin) p >>= si "qmin"+  (#peek AVCodecContext, qmax) p >>= si "qmax"+  (#peek AVCodecContext, me_cmp) p >>= si "me_cmp"+  (#peek AVCodecContext, me_range) p >>= si "me_range"+  putStrLn ""+  where si msg = putStrLn . ((msg++" = ")++) . show :: CInt -> IO ()
+ src/Codec/FFmpeg/Juicy.hs view
@@ -0,0 +1,37 @@+-- | Convert between FFmpeg frames and JuicyPixels images.+module Codec.FFmpeg.Juicy where+import Codec.Picture+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Types+import Control.Applicative+import Control.Arrow ((&&&))+import Control.Monad (when, (>=>))+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as VM+import Foreign.C.Types+import Foreign.Marshal.Array (advancePtr, copyArray)+import Foreign.Ptr (castPtr, Ptr)++-- | Convert an RGB24 'AVFrame' to a 'DynamicImage'.+juicyRGB :: AVFrame -> IO DynamicImage+juicyRGB frame = do+  fmt <- getPixelFormat frame+  when (fmt /= avPixFmtRgb24)+       (putStrLn "Not RGB24?!")+  w <- fromIntegral <$> getWidth frame+  h <- fromIntegral <$> getHeight frame+  pixels <- castPtr <$> getData frame :: IO (Ptr CUChar)+  srcStride <- fromIntegral <$> getLineSize frame+  let dstStride = w * 3+  v <- VM.new (w*h*3)+  VM.unsafeWith v $ \vptr ->+    mapM_ (\(i,o) -> copyArray (advancePtr vptr o)+                               (advancePtr pixels i)+                               (w * 3))+          (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1])+  v' <- V.unsafeFreeze v+  return $ ImageRGB8 (Image w h (V.unsafeCast v'))++-- | Save an RGB24 'AVFrame' to a PNG file on disk.+saveJuicyRGB :: FilePath -> AVFrame -> IO ()+saveJuicyRGB name = juicyRGB >=> savePngImage name
+ src/Codec/FFmpeg/Types.hsc view
@@ -0,0 +1,145 @@+{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances,+             GeneralizedNewtypeDeriving #-}+module Codec.FFmpeg.Types where+import Codec.FFmpeg.Enums+import Control.Applicative+import Foreign.C.String (CString)+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable++#include <libavcodec/avcodec.h>+#include <libavformat/avformat.h>+#include <libavutil/avutil.h>+#include <libswscale/swscale.h>+#include "hscMacros.h"++class HasPtr a where+  getPtr :: a -> Ptr ()++instance HasPtr (Ptr ()) where getPtr = id++newtype AVFormatContext = AVFormatContext (Ptr ()) deriving (Storable, HasPtr)+#mkField NumStreams, CInt+#mkField Streams, (Ptr AVStream)+#mkField OutputFormat, AVOutputFormat+#mkField IOContext, AVIOContext++#hasField AVFormatContext, NumStreams, nb_streams+#hasField AVFormatContext, Streams, streams+#hasField AVFormatContext, OutputFormat, oformat+#hasField AVFormatContext, IOContext, pb++newtype AVCodecContext = AVCodecContext (Ptr ()) deriving (Storable, HasPtr)++#mkField BitRate, CInt+#hasField AVCodecContext, BitRate, bit_rate++#mkField Width, CInt+#mkField Height, CInt+#mkField TimeBase, AVRational+#mkField GopSize, CInt+#mkField PixelFormat, AVPixelFormat+#mkField CodecFlags, CodecFlag+#mkField CodecID, AVCodecID++#hasField AVCodecContext, Width, width+#hasField AVCodecContext, Height, height+#hasField AVCodecContext, TimeBase, time_base+#hasField AVCodecContext, GopSize, gop_size+#hasField AVCodecContext, PixelFormat, pix_fmt+#hasField AVCodecContext, CodecFlags, flags+#hasField AVCodecContext, CodecID, codec_id++newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr)++#mkField Id, CInt+#mkField CodecContext, AVCodecContext+#mkField StreamIndex, CInt++#hasField AVStream, Id, id+#hasField AVStream, TimeBase, time_base+#hasField AVStream, CodecContext, codec+#hasField AVStream, StreamIndex, index++newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr)+#mkField LongName, CString+#mkField Name, CString++#hasField AVCodec, LongName, long_name+#hasField AVCodec, Name, name+#hasField AVCodec, CodecID, id++newtype AVDictionary = AVDictionary (Ptr ()) deriving (Storable, HasPtr)+newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr)+#mkField Pts, CLong+#mkField PktPts, CLong+#mkField LineSize, CInt++#hasField AVFrame, PixelFormat, format+#hasField AVFrame, Width, width+#hasField AVFrame, Height, height+#hasField AVFrame, LineSize, linesize+#hasField AVFrame, Pts, pts+#hasField AVFrame, PktPts, pkt_pts+#hasField AVFrame, Data, data++newtype AVPicture = AVPicture (Ptr ()) deriving (Storable, HasPtr)+newtype SwsContext = SwsContext (Ptr ()) deriving (Storable, HasPtr)+newtype AVOutputFormat = AVOutputFormat (Ptr ()) deriving (Storable, HasPtr)+#mkField FormatFlags, FormatFlag+#hasField AVOutputFormat, FormatFlags, flags++newtype AVIOContext = AVIOContext (Ptr ()) deriving (Storable, HasPtr)++newtype AVPacket = AVPacket (Ptr ()) deriving (Storable, HasPtr)+#mkField Data, (Ptr ())+#hasField AVPacket, Data, data+#mkField Size, CInt+#hasField AVPacket, Size, size++#hasField AVPacket, StreamIndex, stream_index++-- | @sizeof@ the 'AVPacket' structure in bytes.+packetSize :: Int+packetSize = #size AVPacket++-- * Types with Haskell equivalents++data AVRational = AVRational { numerator   :: CInt+                             , denomenator :: CInt } deriving Show++instance Storable AVRational where+  sizeOf _ = #size AVRational+  alignment _ = #size AVRational+  peek ptr = AVRational <$> (#peek AVRational, num) ptr+                        <*> (#peek AVRational, den) ptr+  poke ptr (AVRational n d) = do (#poke AVRational, num) ptr n+                                 (#poke AVRational, den) ptr d++foreign import ccall "av_rescale_rnd"+  av_rescale_rnd :: CLong -> CLong -> CLong -> AVRoundMode -> CLong++-- | Convert an 'AVRational' to a 'Double'+av_q2d :: AVRational -> CDouble+av_q2d r = fromIntegral (numerator r) / fromIntegral (denomenator r)++-- | Rescale an integer from one time base to another.+av_rescale_q :: CLong -> AVRational -> AVRational -> CLong+av_rescale_q a bq cq = av_rescale_rnd a b c avRoundNearInf+  where b = fromIntegral (numerator bq) * fromIntegral (denomenator cq)+        c = fromIntegral (numerator cq) * fromIntegral (denomenator bq)++data AVFrac = AVFrac { fracVal :: CLong+                     , fracNum :: CLong+                     , fracDen :: CLong } deriving Show++instance Storable AVFrac where+  sizeOf _ = #size AVFrac+  alignment _ = #size AVFrac+  peek ptr = AVFrac <$> (#peek AVFrac, val) ptr+                    <*> (#peek AVFrac, num) ptr+                    <*> (#peek AVFrac, den) ptr+  poke ptr (AVFrac v n d) = do (#poke AVFrac, val) ptr v+                               (#poke AVFrac, num) ptr n+                               (#poke AVFrac, den) ptr d
+ src/hscMacros.h view
@@ -0,0 +1,45 @@+#include <stdio.h>++/*+Creates a class for a field with a particular Haskell type.+Example: #mkField Width, CInt+Generates:+class HasWidth t where+  getWidth :: t -> IO CInt+  setWidth :: t -> CInt -> IO ()+  hasWidth :: t -> Ptr CInt+*/++#define hsc_mkField(name, hType) \+  printf("class Has%s t where\n", #name);\+  printf("  get%s :: t -> IO %s\n", #name, #hType);\+  printf("  set%s :: t -> %s -> IO ()\n", #name, #hType);\+  printf("  has%s :: t -> Ptr %s\n", #name, #hType);++/*+Creates an instance of settable field class. The assumption is that+the first argument, the type name, is the name of bot the C and+Haskell types involved. This makes use of the HasPtr class whose+single method, getPtr, with type "a -> Ptr ()", unwraps a raw Ptr from+a value (typically a newtype around a Ptr).++Example: #hasField AVCodecContext, BitRate, bit_rate+Generates:+instance HasBitRate AVCodecContext where+  getBitRate = (#peek AVCodecContext, bit_rate) . getPtr+  setBitRate = (#poke AVCodecContext, bit_rate) . getPtr+  hasBitRate = (#ptr AVCodecContext, bit_rate) . getPtr+*/++#define hsc_hasField(type, hName, cName) \+   printf("instance Has%s %s where\n", #hName, #type);\+   printf("  get%s = ", #hName);\+   hsc_peek(type, cName)\+   printf(" . getPtr\n");\+   printf("  set%s = ", #hName);\+   hsc_poke(type, cName)\+   printf(" . getPtr\n");\+   printf("  has%s = ", #hName);\+   hsc_ptr(type, cName)\+   printf(" . getPtr\n");+