ffmpeg-light 0.13.0 → 0.14.0
raw patch · 18 files changed
+1415/−268 lines, 18 filesdep +stmdep ~JuicyPixelsdep ~basedep ~mtlnew-component:exe:audio-extractnew-component:exe:audio-sin
Dependencies added: stm
Dependency ranges changed: JuicyPixels, base, mtl, vector
Files
- CHANGELOG.md +5/−0
- demo/AudioExtract.hs +74/−0
- demo/AudioSin.hs +144/−0
- demo/Main.hs +7/−15
- demo/Transcode.hs +4/−2
- ffmpeg-light.cabal +40/−4
- src/Codec/FFmpeg.hs +5/−2
- src/Codec/FFmpeg/AudioStream.hs +106/−0
- src/Codec/FFmpeg/Common.hsc +138/−25
- src/Codec/FFmpeg/Decode.hs +91/−16
- src/Codec/FFmpeg/Encode.hsc +511/−185
- src/Codec/FFmpeg/Enums.hsc +5/−8
- src/Codec/FFmpeg/Internal/Debug.hsc +6/−0
- src/Codec/FFmpeg/Juicy.hs +13/−5
- src/Codec/FFmpeg/Probe.hsc +1/−0
- src/Codec/FFmpeg/Resampler.hs +149/−0
- src/Codec/FFmpeg/Scaler.hs +1/−1
- src/Codec/FFmpeg/Types.hsc +115/−5
CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.14.0+* Audio support+* New demo for extracting audio from a video to a mp3+* New demo with both video and audio using sinusoidal audio waves+ # 0.13.0 * Support webcams on Linux
+ demo/AudioExtract.hs view
@@ -0,0 +1,74 @@+module Main where++import Codec.FFmpeg+import Codec.FFmpeg.AudioStream+import Codec.FFmpeg.Decode+import Codec.FFmpeg.Encode+import Codec.FFmpeg.Resampler+import Control.Monad.Except+import System.Environment+++main :: IO ()+main = do initFFmpeg+ args <- getArgs++ case args of+ [fname, outname] -> do+ eRes <- runExceptT $ frameAudioReader (File fname)+ case eRes of+ Left er -> error er+ Right (as, getFrame, cleanup) -> do+ putStrLn $ "bitrate : " ++ show (asBitRate as)+ putStrLn $ "sample rate : " ++ show (asSampleRate as)+ putStrLn $ "sample format : " +++ show (getSampleFormatInt (asSampleFormat as))+ putStrLn $ "channel layout : " ++ show (asChannelLayout as)+ putStrLn $ "channel count : " ++ show (asChannelCount as)+ let inParams = AudioParams+ { apChannelLayout = asChannelLayout as+ , apSampleRate = asSampleRate as+ , apSampleFormat = asSampleFormat as+ }+ outParams = AudioParams+ { apChannelLayout = asChannelLayout as+ , apSampleRate = 44100+ , apSampleFormat = asSampleFormat as+ }+ encParams = AEncodingParams+ { aepChannelLayout = apChannelLayout outParams+ , aepSampleRate = apSampleRate outParams+ , aepSampleFormat = apSampleFormat outParams+ , aepPreset = ""+ , aepFormatName = Nothing+ }+ (mCtx, audWriter) <- audioWriter encParams outname+ case mCtx of+ Nothing -> error "Didn't get audio context"+ Just ctx -> do+ (sendFrame, getResampledFrame) <- makeResampler ctx inParams outParams+ let go :: Int -> IO ()+ go i = do+ mFrame <- getFrame+ case mFrame of+ Nothing -> readAndWrite+ Just frame -> do+ sendFrame frame+ readAndWrite+ go (i+1)+ readAndWrite = do+ mFrame <- getResampledFrame+ case mFrame of+ Nothing -> return ()+ Just frame -> do+ audWriter (Just frame)+ readAndWrite+ go 1+ audWriter Nothing++ cleanup+ return ()+ return ()+ _ -> putStrLn usage+ where+ usage = "Supply an input video and output filename to extract the audio file to a mp3 file"
+ demo/AudioSin.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE MultiWayIf #-}+module Main where++import Codec.FFmpeg+import Codec.FFmpeg.AudioStream+import Codec.FFmpeg.Common+import Codec.FFmpeg.Encode+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Juicy+import Codec.FFmpeg.Types+import Codec.Picture+import Control.Monad.Except+import Data.IORef+import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import System.Environment++-- Simple Music DSL+type Sound = Float -> Float++volume :: Float -> Sound -> Sound+volume v s t = v * (s t)++mkNote :: Float -> Sound+mkNote f = \t -> sin (f * 2 * pi * t)++a4 :: Sound+a4 = mkNote 440++c4 :: Sound+c4 = mkNote 261.6256++d4 :: Sound+d4 = mkNote 293.6648++e4 :: Sound+e4 = mkNote 329.6276++f4 :: Sound+f4 = mkNote 349.2282++g4 :: Sound+g4 = mkNote 391.9954++b4 :: Sound+b4 = mkNote 493.8833++c5 :: Sound+c5 = mkNote 523.2511++e5 :: Sound+e5 = mkNote 659.2551++combineSounds :: [Sound] -> Sound+combineSounds snds t = sum $ map (\s -> s t) snds++-- Take sounds and their duration and put them in order+sequenceSounds :: [(Float, Sound)] -> Sound+sequenceSounds snds tin = go tin snds+ where+ go t [(_,snd)] = snd t+ go t ((dur,snd):rest)+ | t <= dur = snd t+ | otherwise = go (t-dur) rest+ go _ _ = 0++cMaj7 = combineSounds [ volume 0.23 c4, volume 0.23 e4, volume 0.23 g4, volume 0.23 b4 ]+dMin7 = combineSounds [ volume 0.23 d4, volume 0.23 f4, volume 0.23 a4, volume 0.23 c5 ]+g7 = combineSounds [ volume 0.23 g4, volume 0.23 a4, volume 0.23 c5, volume 0.23 e5 ]+-- ii - V7 - I jazz chord progression+twoFiveOne = sequenceSounds [(1, dMin7), (1, g7), (1, cMaj7)]++mkImage :: Int -> Int -> PixelRGB8 -> Image PixelRGB8+mkImage w h color =+ generateImage (\_ _ -> color) w h++main :: IO ()+main = do+ initFFmpeg++ let w = 1080+ h = 720+ encParams = AVEncodingParams+ { avepWidth = w+ , avepHeight = h+ , avepFps = 30+ , avepCodec = Nothing+ , avepPixelFormat = Nothing+ , avepChannelLayout = avChLayoutMono+ , avepSampleRate = 44100+ , avepSampleFormat = avSampleFmtFltp+ , avepPreset = ""+ , avepFormatName = Nothing+ }+ writerContext <- audioVideoWriter encParams "sinusoidal.mp4"+ let mCtx = avwAudioCodecContext writerContext+ videoWriter = avwVideoWriter writerContext+ audioWriter = avwAudioWriter writerContext+ case mCtx of+ Nothing -> error "Could not get audio ctx"+ Just ctx -> do+ frame <- frame_alloc_check+ setNumSamples frame =<< getFrameSize ctx+ setFormat frame . getSampleFormatInt =<< getSampleFormat ctx+ setChannelLayout frame =<< getChannelLayout ctx+ setSampleRate frame =<< getSampleRate ctx++ ch <- getChannelLayout ctx+ numChannels <- getChannels ctx++ print ("Channel Layout", ch)+ print ("Channels", numChannels)++ runWithError "Alloc buffers" (av_frame_get_buffer frame 0)++ let sampleRate = avepSampleRate encParams+ print ("sample rate", sampleRate)++ vidFrameRef <- newIORef 0 :: IO (IORef Int)+ forM_ [0..120] $ \i -> do+ av_frame_make_writable frame+ dataPtr <- castPtr <$> getData frame :: IO (Ptr CFloat)+ nbSamples <- getNumSamples frame+ forM_ [0..nbSamples-1] $ \j -> do+ let idx = fromIntegral i * fromIntegral nbSamples + fromIntegral j :: Integer+ t = fromIntegral idx / fromIntegral sampleRate+ v = twoFiveOne t+ poke (advancePtr dataPtr (fromIntegral j)) (realToFrac v)+ vidFrame <- readIORef vidFrameRef+ when (t * 30 >= fromIntegral vidFrame) $ do+ -- TODO: I'm not sure why t seems to be half the actual value but I need to do+ -- 0.5 and 1 to make the chord changes match up with the color changes+ modifyIORef vidFrameRef (+1)+ let color = if | t <= 1 -> PixelRGB8 255 0 0+ | t <= 2 -> PixelRGB8 0 255 0+ | otherwise -> PixelRGB8 0 0 255+ img = mkImage (fromIntegral w) (fromIntegral h) color+ videoWriter (Just (fromJuciy img))+ audioWriter (Just frame)++ videoWriter Nothing+ audioWriter Nothing
demo/Main.hs view
@@ -66,17 +66,17 @@ unless (realToFrac (C.diffUTCTime now start) >= time) go go -testCamera :: String -> IO ()-testCamera cameraDevice =+testCamera :: IO ()+testCamera = do initFFmpeg -- Defaults to quiet (minimal) logging -- setLogLevel avLogInfo -- Restore standard ffmpeg logging- putStrLn "Opening camera..."+ (getFrame, cleanup) <- imageReader $ case Info.os of "linux" -> let cfg = CameraConfig (Just 30) Nothing (Just "mjpeg") -- (Just "v4l2")- in Camera ("/dev/video" <> cameraDevice) cfg+ in Camera "/dev/video0" cfg "darwin" -> Camera "0:0" defaultCameraConfig _ -> error "Unsure how to identify a default camera input" @@ -96,23 +96,15 @@ main = do args <- getArgs case args of [] -> testEncode- ["cam", n] -> testCamera n [s]- | s `elem` ["--help", "-help", "-h"] -> putStrLn usage- | s == "cam" -> testCamera "0"+ | s `elem` ["--help", "-help", "-h"] -> error usage+ | s == "cam" -> testCamera [vidFile] -> testDecode vidFile _ -> error usage where usage =- unlines [ "Usage: demo [cam [N]|videoFile]"+ unlines [ "Usage: demo [videoFile]" , " If no argument is given, a test video named " , " pulse.mov is generated."- , ""- , " If the word 'cam' (without quotes) is given as an "- , " argument, an attached webcam is opened and used to "- , " record a 10s video saved to the file camera.mov. "- , " On Linux, the camera is found at /dev/videoN where N "- , " is an argument following the word 'cam'. If no value "- , " is given for N, a default of 0 is used." , "" , " If a file name is given, then two frames are " , " extracted: the first frame, and the 301st."
demo/Transcode.hs view
@@ -30,8 +30,10 @@ _ -> error usage copy :: FilePath -> FilePath -> String -> Int -> Int -> IO ()-copy from to format w h = let ep = (FF.defaultH264 (fromIntegral w) (fromIntegral h))- { FF.epFormatName = Just format } in do+copy from to format w h = do+ let ep = (FF.defaultH264 (fromIntegral w) (fromIntegral h))+ -- { FF.epFormatName = Just format }+ -- TODO: get this working again (getFrame, cleanup) <- FF.imageReader (FF.File from) putFrame <- FF.imageWriter ep to loop getFrame cleanup putFrame (\x -> return x)
ffmpeg-light.cabal view
@@ -1,5 +1,5 @@ name: ffmpeg-light-version: 0.13.0+version: 0.14.0 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to@@ -15,7 +15,7 @@ > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" > (fmap ImageRGB8 <$> getFrame) <* cleanup .- Tested with FFmpeg 3.1 - 4.3.1+ Tested with FFmpeg 3.1 - 3.4.2 license: BSD3 license-file: LICENSE@@ -28,7 +28,7 @@ build-type: Simple extra-source-files: src/hscMacros.h, src/nameCompat.h, CHANGELOG.md cabal-version: >=1.10-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.6.5, GHC == 8.8.4+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 source-repository head type: git@@ -54,14 +54,26 @@ default: False manual: True +flag BuildAudioExtractDemo+ description: Build audio-extract demo executable+ default: False+ manual: True++flag BuildAudioSinDemo+ description: Build audio-sin demo executable+ default: False+ manual: True+ library exposed-modules: Codec.FFmpeg,+ Codec.FFmpeg.AudioStream, Codec.FFmpeg.Common, Codec.FFmpeg.Decode, Codec.FFmpeg.Encode, Codec.FFmpeg.Enums, Codec.FFmpeg.Juicy, Codec.FFmpeg.Probe,+ Codec.FFmpeg.Resampler, Codec.FFmpeg.Scaler, Codec.FFmpeg.Types, Codec.FFmpeg.Internal.Debug,@@ -71,12 +83,14 @@ either, exceptions, vector >= 0.10.9 && < 0.13,+ stm >= 2.0.0.0 && < 3.0.0.0.0, transformers >= 0.4.1 && < 0.6, mtl >= 2.2.1 && < 2.3, JuicyPixels >= 3.1 && < 3.4, bytestring - pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice+ pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice,+ libswresample hs-source-dirs: src include-dirs: src default-language: Haskell2010@@ -123,5 +137,27 @@ build-depends: ffmpeg-light hs-source-dirs: demo main-is: Transcode.hs+ default-language: Haskell2010+ ghc-options: -Wall++executable audio-extract+ if !flag(BuildAudioExtractDemo)+ buildable: False+ build-depends: base < 5+ if flag(BuildAudioExtractDemo)+ build-depends: ffmpeg-light, mtl, vector+ hs-source-dirs: demo+ main-is: AudioExtract.hs+ default-language: Haskell2010+ ghc-options: -Wall++executable audio-sin+ if !flag(BuildAudioSinDemo)+ buildable: False+ build-depends: base < 5+ if flag(BuildAudioSinDemo)+ build-depends: ffmpeg-light, mtl, vector, JuicyPixels+ hs-source-dirs: demo+ main-is: AudioSin.hs default-language: Haskell2010 ghc-options: -Wall
src/Codec/FFmpeg.hs view
@@ -7,14 +7,17 @@ imageReader, imageReaderTime, imageReaderT, imageReaderTimeT, -- * Encoding- EncodingParams(..), defaultParams, imageWriter,+ EncodingParams(..), StreamParams(..),+ VideoParams(..), AudioParams(..),+ defaultParams, imageWriter, -- * Types and Enums- module Codec.FFmpeg.Types, + module Codec.FFmpeg.Types, module Codec.FFmpeg.Enums )where import Codec.FFmpeg.Encode import Codec.FFmpeg.Enums import Codec.FFmpeg.Juicy+import Codec.FFmpeg.Resampler import Codec.FFmpeg.Types import Foreign.C.Types (CInt(..))
+ src/Codec/FFmpeg/AudioStream.hs view
@@ -0,0 +1,106 @@+module Codec.FFmpeg.AudioStream where++import Codec.FFmpeg.Enums+import Data.Bits+import qualified Data.Vector.Storable as V+import Foreign.C.Types++data AudioStream = AudioStream+ { asBitRate :: CInt+ , asSampleFormat :: AVSampleFormat+ , asSampleRate :: CInt+ , asChannelLayout :: CULong+ , asChannelCount :: CInt+ , asCodec :: AVCodecID+ }++-- These are all defined as #defines so I don't think we can FFI them+avChFrontLeft :: CULong+avChFrontLeft = 0x00000001++avChFrontRight :: CULong+avChFrontRight = 0x00000002++avChFrontCenter :: CULong+avChFrontCenter = 0x00000004++avChLowFrequency :: CULong+avChLowFrequency = 0x00000008++avChBackLeft :: CULong+avChBackLeft = 0x00000010++avChBackRight :: CULong+avChBackRight = 0x00000020++avChFrontLeftOfCenter :: CULong+avChFrontLeftOfCenter = 0x00000040++avChFrontRightOfCenter :: CULong+avChFrontRightOfCenter = 0x00000080++avChBackCenter :: CULong+avChBackCenter = 0x00000100++avChSideLeft :: CULong+avChSideLeft = 0x00000200++avChSideRight :: CULong+avChSideRight = 0x00000400++avChTopCenter :: CULong+avChTopCenter = 0x00000800++avChTopFrontLeft :: CULong+avChTopFrontLeft = 0x00001000++avChTopFrontCenter :: CULong+avChTopFrontCenter = 0x00002000++avChTopFrontRight :: CULong+avChTopFrontRight = 0x00004000++avChTopBackLeft :: CULong+avChTopBackLeft = 0x00008000++avChTopBackCenter :: CULong+avChTopBackCenter = 0x00010000++avChTopBackRight :: CULong+avChTopBackRight = 0x00020000++avChStereoLeft :: CULong+avChStereoLeft = 0x20000000++avChStereoRight :: CULong+avChStereoRight = 0x40000000++avChLayoutMono = avChFrontCenter+avChLayoutStereo = avChFrontLeft .|. avChFrontRight+avChLayout2point1 = avChLayoutStereo .|. avChLowFrequency+avChLayout21 = avChLayoutStereo .|. avChBackCenter+avChLayoutSurround = avChLayoutStereo .|. avChFrontCenter+avChLayout3point1 = avChLayoutSurround .|. avChLowFrequency+avChLayout4point0 = avChLayoutSurround .|. avChBackCenter+avChLayout4point1 = avChLayout4point0 .|. avChLowFrequency+avChLayout22 = avChLayoutStereo .|. avChSideLeft .|. avChSideRight+avChLayoutQuad = avChLayoutStereo .|. avChBackLeft .|. avChBackRight+avChLayout5point0 = avChLayoutSurround .|. avChSideLeft .|. avChSideRight+avChLayout5point1 = avChLayout5point0 .|. avChLowFrequency+avChLayout5point0Back = avChLayoutSurround .|. avChBackLeft .|. avChBackRight+avChLayout5point1Back = avChLayout5point0Back .|. avChLowFrequency+avChLayout6point0 = avChLayout5point0 .|. avChBackCenter+avChLayout6point0Front = avChLayout22 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter+avChLayoutHexagonal = avChLayout5point0Back .|. avChBackCenter+avChLayout6point1 = avChLayout5point1 .|. avChBackCenter+avChLayout6point1Back = avChLayout5point1Back .|. avChBackCenter+avChLayout6point1Front = avChLayout6point0Front .|. avChLowFrequency+avChLayout7point0 = avChLayout5point0 .|. avChBackLeft .|. avChBackRight+avChLayout7point0Front = avChLayout5point0 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter+avChLayout7point1 = avChLayout5point1 .|. avChBackLeft .|. avChBackRight+-- avChLayout7point1Wide = avChLayout5point1 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter+-- avChLayout7point1WideBack = avChLayout5point1Back .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter+avChLayoutOctagonal = avChLayout5point0 .|. avChBackLeft .|. avChBackCenter .|. avChBackRight+-- avChLayoutHexadecagonal = avChLayoutOctagonal .|. avChWideLeft .|. avChWideRight .|. avChTopBackLeft .|. avChTopBackRight .|. avChTopBackCenter .|. avChTopFrontCenter .|. avChTopFrontLeft .|. avChTopFrontRight+avChLayoutStereoDownmix = avChStereoLeft .|. avChStereoRight+
src/Codec/FFmpeg/Common.hsc view
@@ -1,15 +1,19 @@-{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE 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+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Types+import Control.Exception+import Control.Monad (when)+import Control.Monad.Error.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc (allocaBytes, free)+import Foreign.Marshal.Array (advancePtr, mallocArray)+import Foreign.Ptr+import Foreign.Storable foreign import ccall "avcodec_open2" open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt@@ -29,6 +33,9 @@ foreign import ccall "av_init_packet" init_packet :: AVPacket -> IO () +foreign import ccall "av_packet_alloc"+ av_packet_alloc :: IO AVPacket+ foreign import ccall "av_free_packet" free_packet :: AVPacket -> IO () @@ -50,6 +57,45 @@ -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt +foreign import ccall "av_get_channel_layout_nb_channels"+ av_get_channel_layout_nb_channels :: CULong -> IO CInt++foreign import ccall "swr_alloc"+ swr_alloc :: IO SwrContext++foreign import ccall "swr_init"+ swr_init :: SwrContext -> IO CInt++foreign import ccall "av_opt_set_int"+ av_opt_set_int :: Ptr () -> CString -> CLong -> CInt -> IO CInt++foreign import ccall "av_opt_get_int"+ av_opt_get_int :: Ptr () -> CString -> CInt -> Ptr CULong -> IO CInt++foreign import ccall "av_opt_set_sample_fmt"+ av_opt_set_sample_fmt :: Ptr () -> CString -> AVSampleFormat -> CInt -> IO CInt++foreign import ccall "av_opt_get_sample_fmt"+ av_opt_get_sample_fmt :: Ptr () -> CString -> CInt -> Ptr AVSampleFormat -> IO CInt++foreign import ccall "avcodec_send_frame"+ avcodec_send_frame :: AVCodecContext -> AVFrame -> IO CInt++foreign import ccall "avcodec_send_packet"+ avcodec_send_packet :: AVCodecContext -> AVPacket -> IO CInt++foreign import ccall "avcodec_receive_frame"+ avcodec_receive_frame :: AVCodecContext -> AVFrame -> IO CInt++foreign import ccall "avcodec_receive_packet"+ avcodec_receive_packet :: AVCodecContext -> AVPacket -> IO CInt++foreign import ccall "av_get_channel_name"+ av_get_channel_name :: CULong -> IO CString++foreign import ccall "av_get_channel_description"+ av_get_channel_description :: CULong -> IO CString+ -- Return size of buffer for image. foreign import ccall "av_image_get_buffer_size" av_image_get_buffer_size@@ -63,7 +109,7 @@ -> CInt -- Size of buffer. -> IO CInt- + -- Copy image to buffer. foreign import ccall "av_image_copy_to_buffer" av_image_copy_to_buffer@@ -85,8 +131,8 @@ -> CInt -- Number of bytes written to destination. -> IO CInt- - ++ -- * Utility functions -- | Catch an IOException from an IO action and re-throw it in a@@ -95,6 +141,25 @@ wrapIOError io = liftIO (catchError (fmap Right io) (return . Left . show)) >>= either throwError return +newtype FFmpegException = FFmpegException String deriving Show++instance Exception FFmpegException++runWithError :: String -> IO CInt -> IO CInt+runWithError msg toRun = do+ r <- toRun+ when (r < 0) $ do+ let len = 100 -- I have no idea how long this string should be so this is a guess+ errCStr <- mallocArray len+ av_strerror r errCStr (fromIntegral len)+ errStr <- peekCString errCStr+ free errCStr+ avError $ msg ++ " : " ++ errStr+ return r++avError :: String -> IO a+avError msg = throwIO $ FFmpegException $ msg+ -- * Wrappers that may throw 'IOException's. -- | Allocate an 'AVFrame' and set its fields to default values.@@ -123,7 +188,7 @@ | fmt == avPixFmtRgb8 = Just 1 | fmt == avPixFmtPal8 = Just 1 | otherwise = Nothing- + -- | Return line size alignment. lineSizeAlign :: CInt -> CInt lineSizeAlign lineSize@@ -146,25 +211,25 @@ frameLineSize :: AVFrame -> IO (Maybe CInt) frameLineSize frame = do w <- getWidth frame- fmt <- getPixelFormat frame + fmt <- getPixelFormat frame return $ (*w) . fromIntegral <$> avPixelStride fmt -- | Transformer version of 'frameLineSize'. frameLineSizeT :: AVFrame -> MaybeT IO CInt-frameLineSizeT = MaybeT . frameLineSize +frameLineSizeT = MaybeT . frameLineSize -- Return 'AVFrame's alignment. frameAlign :: AVFrame -> IO (Maybe CInt)-frameAlign = fmap (fmap lineSizeAlign) . frameLineSize +frameAlign = fmap (fmap lineSizeAlign) . frameLineSize -- Transformer version of 'frameAlign'. frameAlignT :: AVFrame -> MaybeT IO CInt frameAlignT = MaybeT . frameAlign --- * Wrappers for copying 'AVFrame's image to buffer. - +-- * Wrappers for copying 'AVFrame's image to buffer.+ -- | Return size of buffer for 'AVFrame's image. frameBufferSize :: AVFrame -> IO (Maybe CInt) frameBufferSize frame =@@ -180,22 +245,22 @@ frameBufferSizeT :: AVFrame -> MaybeT IO CInt frameBufferSizeT = MaybeT . frameBufferSize --- | Copy 'AVFrame's image to buffer. +-- | 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 frame buffer = runMaybeT $ do- + a <- frameAlignT frame s <- frameBufferSizeT frame- + MaybeT $ do- + let imageData = hasData frame lineSize = hasLineSize frame- + fmt <- getPixelFormat frame w <- getWidth frame h <- getHeight frame@@ -228,3 +293,51 @@ peekCString buf where len = 1000++-- | Walk a C array placing the values into a Haskell list.+-- Stop incrementing the pointer when the function returns True+walkPtrs :: Storable a+ => Ptr a -- ^ Ptr to the beginning of an array+ -> (Ptr a -> IO Bool) -- ^ Function to specify when we should terminate+ -> IO [a]+walkPtrs ptr isDone = do+ d <- isDone ptr+ if d+ then return []+ else do+ v <- peek ptr+ rest <- walkPtrs (advancePtr ptr 1) isDone+ return $ v : rest++listSupportedSampleFormats :: AVCodec -> IO [AVSampleFormat]+listSupportedSampleFormats codec = do+ fmts <- getSampleFormats codec+ walkPtrs fmts (\ptr ->+ if ptr == nullPtr+ then return True+ else do+ v <- peek ptr+ return $ getSampleFormatInt v == -1+ )++listSupportedChannelLayouts :: AVCodec -> IO [CULong]+listSupportedChannelLayouts codec = do+ chanPtr <- getChannelLayouts codec+ walkPtrs chanPtr (\ptr ->+ if ptr == nullPtr+ then return True+ else do+ v <- peek ptr+ return $ v == 0+ )++listSupportedSampleRates :: AVCodec -> IO [CInt]+listSupportedSampleRates codec = do+ srPtr <- getSupportedSampleRates codec+ walkPtrs srPtr (\ptr ->+ if ptr == nullPtr+ then return True+ else do+ v <- peek ptr+ return $ v == 0+ )
src/Codec/FFmpeg/Decode.hs view
@@ -1,24 +1,28 @@-{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE 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 +import Codec.FFmpeg.AudioStream+import Codec.FFmpeg.Common+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Scaler+import Codec.FFmpeg.Types+import Control.Arrow (first)+import Control.Monad (void, when)+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"@@ -47,6 +51,10 @@ foreign import ccall "av_read_frame" av_read_frame :: AVFormatContext -> AVPacket -> IO CInt +foreign import ccall "avcodec_decode_audio4"+ decode_audio :: AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket+ -> IO CInt+ foreign import ccall "avcodec_decode_video2" decode_video :: AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket -> IO CInt@@ -164,6 +172,20 @@ ctx <- getCodecContext vidStream return (i, ctx, cod, vidStream) +findAudioStream :: (MonadIO m, MonadError String m)+ => AVFormatContext+ -> m (CInt, AVCodecContext, AVCodec, AVStream)+findAudioStream fmt = do+ wrapIOError . alloca $ \codec -> do+ poke codec (AVCodec nullPtr)+ i <- av_find_best_stream fmt avmediaTypeAudio (-1) (-1) codec 0+ when (i < 0) (fail "Couldn't find audio stream")+ cod <- peek codec+ streams <- getStreams fmt+ audioStream <- peek (advancePtr streams (fromIntegral i))+ ctx <- getCodecContext audioStream+ return (i, ctx, cod, audioStream)+ -- | Find a registered decoder with a codec ID matching that found in -- the given 'AVCodecContext'. getDecoder :: (MonadIO m, MonadError String m)@@ -229,6 +251,31 @@ return $ Just (f, t) return (readTS, cleanup) +frameAudioReader :: (MonadIO m, MonadError String m)+ => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO ())+frameAudioReader fileName = do+ inputContext <- openInput fileName+ checkStreams inputContext+ (audioStreamIndex, ctx, cod, audioStream) <- findAudioStream inputContext+ openCodec ctx cod+ as <- liftIO $ do+ bitrate <- getBitRate ctx+ samplerate <- getSampleRate ctx+ channelLayout <- getChannelLayout ctx+ sampleFormat <- getSampleFormat ctx+ channels <- getChannels ctx+ codecId <- getCodecID cod+ return $ AudioStream+ { asBitRate = bitrate+ , asSampleRate = samplerate+ , asSampleFormat = sampleFormat+ , asChannelLayout = channelLayout+ , asChannelCount = channels+ , asCodec = codecId+ }+ (readFrame, finalize) <- prepareAudioReader inputContext audioStreamIndex ctx+ return (as, readFrame, finalize)+ -- | Read time stamped RGB frames with the result in the 'MaybeT' -- transformer. --@@ -236,6 +283,34 @@ frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m) => InputSource -> m (MaybeT IO (AVFrame, Double), IO ()) frameReaderTimeT = fmap (first MaybeT) . frameReaderTime avPixFmtRgb24++prepareAudioReader :: (MonadIO m, MonadError String m)+ => AVFormatContext -> CInt -> AVCodecContext+ -> m (IO (Maybe AVFrame), IO ())+prepareAudioReader fmtCtx audStream codCtx =+ wrapIOError $ do+ frame <- frame_alloc_check+ pkt <- av_packet_alloc+ let cleanup = do with frame av_frame_free+ _ <- codec_close codCtx+ with fmtCtx close_input+ free (getPtr pkt)+ getFrame = do+ ret <- avcodec_receive_frame codCtx frame+ if ret < 0+ then do+ r <- av_read_frame fmtCtx pkt+ if r < 0+ then return Nothing+ else do+ whichStream <- getStreamIndex pkt+ if whichStream == audStream+ then do+ runWithError "Error sending packet" (avcodec_send_packet codCtx pkt)+ getFrame+ else free_packet pkt >> getFrame+ else return $ Just frame+ return (getFrame `catchError` const (return Nothing), cleanup) -- | Construct an action that gets the next available frame, and an -- action to release all resources associated with this video stream.
src/Codec/FFmpeg/Encode.hsc view
@@ -9,6 +9,7 @@ import Codec.FFmpeg.Common import Codec.FFmpeg.Enums import Codec.FFmpeg.Internal.Linear+import Codec.FFmpeg.Resampler import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types import Codec.Picture@@ -25,8 +26,11 @@ import Foreign.C.Types import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Marshal.Alloc+import Foreign.Marshal.Array (advancePtr) import Foreign.Marshal.Utils +import Codec.FFmpeg.Internal.Debug+ import Foreign.Ptr import Foreign.Storable @@ -95,44 +99,169 @@ foreign import ccall "av_image_fill_linesizes" av_image_fill_linesizes :: Ptr CInt -> AVPixelFormat -> CInt -> IO CInt +foreign import ccall "av_frame_make_writable"+ av_frame_make_writable :: AVFrame -> IO CInt+ -- * FFmpeg Encoding Interface -- | Minimal parameters describing the desired video output.-data EncodingParams =- EncodingParams { epWidth :: CInt- , epHeight :: CInt- , epFps :: Int- , epCodec :: Maybe AVCodecID- -- ^ If 'Nothing', then the codec is inferred from- -- the output file name. If 'Just', then this codec- -- is manually chosen.- , epPixelFormat :: Maybe AVPixelFormat- -- ^ If 'Nothing', automatically chose a pixel format- -- based on the output codec. If 'Just', force the- -- selected pixel format.- , epPreset :: String- -- ^ Encoder-specific hints. For h264, the default- -- preset is @\"medium\"@ (other options are- -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,- -- setting this to @\"dither\"@ will enable dithering- -- during the palettization process. This will- -- improve image quality, but result in a larger- -- file.- , epFormatName :: Maybe String- -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer- -- from the output file name. If 'Just', the string value- -- should be the one available in @ffmpeg -formats@.- }+data EncodingParams = EncodingParams+ { epWidth :: CInt+ , epHeight :: CInt+ , epFps :: Int+ , epCodec :: Maybe AVCodecID+ -- ^ If 'Nothing', then the codec is inferred from+ -- the output file name. If 'Just', then this codec+ -- is manually chosen.+ , epPixelFormat :: Maybe AVPixelFormat+ -- ^ If 'Nothing', automatically chose a pixel format+ -- based on the output codec. If 'Just', force the+ -- selected pixel format.+ , epPreset :: String+ -- ^ Encoder-specific hints. For h264, the default+ -- preset is @\"medium\"@ (other options are+ -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,+ -- setting this to @\"dither\"@ will enable dithering+ -- during the palettization process. This will+ -- improve image quality, but result in a larger+ -- file.+ , epFormatName :: Maybe String+ -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer+ -- from the output file name. If 'Just', the string value+ -- should be the one available in @ffmpeg -formats@.+ } +-- | Minimal parameters describing the desired audio/video output.+data AVEncodingParams = AVEncodingParams+ { avepWidth :: CInt+ , avepHeight :: CInt+ , avepFps :: Int+ , avepCodec :: Maybe AVCodecID+ -- ^ If 'Nothing', then the codec is inferred from+ -- the output file name. If 'Just', then this codec+ -- is manually chosen.+ , avepPixelFormat :: Maybe AVPixelFormat+ -- ^ If 'Nothing', automatically chose a pixel format+ -- based on the output codec. If 'Just', force the+ -- selected pixel format.+ , avepChannelLayout :: CULong+ -- ^ Channel layout for the audio stream+ , avepSampleRate :: CInt+ -- ^ Sample rate for the audio stream+ , avepSampleFormat :: AVSampleFormat+ -- ^ Sample format for the audio stream+ , avepPreset :: String+ -- ^ Encoder-specific hints. For h264, the default+ -- preset is @\"medium\"@ (other options are+ -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,+ -- setting this to @\"dither\"@ will enable dithering+ -- during the palettization process. This will+ -- improve image quality, but result in a larger+ -- file.+ , avepFormatName :: Maybe String+ -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer+ -- from the output file name. If 'Just', the string value+ -- should be the one available in @ffmpeg -formats@.+ }++-- | Minimal parameters describing the desired audio/video output.+data AEncodingParams = AEncodingParams+ { aepChannelLayout :: CULong+ -- ^ Channel layout for the audio stream+ , aepSampleRate :: CInt+ -- ^ Sample rate for the audio stream+ , aepSampleFormat :: AVSampleFormat+ -- ^ Sample format for the audio stream+ , aepPreset :: String+ -- ^ Encoder-specific hints. For h264, the default+ -- preset is @\"medium\"@ (other options are+ -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,+ -- setting this to @\"dither\"@ will enable dithering+ -- during the palettization process. This will+ -- improve image quality, but result in a larger+ -- file.+ , aepFormatName :: Maybe String+ -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer+ -- from the output file name. If 'Just', the string value+ -- should be the one available in @ffmpeg -formats@.+ }++data VideoParams = VideoParams+ { vpWidth :: CInt+ , vpHeight :: CInt+ , vpFps :: Int+ , vpCodec :: Maybe AVCodecID+ , vpPixelFormat :: Maybe AVPixelFormat+ , vpPreset :: String+ }++class HasVideoParams a where+ extractVideoParams :: a -> VideoParams++instance HasVideoParams EncodingParams where+ extractVideoParams ep = VideoParams+ { vpWidth = epWidth ep+ , vpHeight = epHeight ep+ , vpFps = epFps ep+ , vpCodec = epCodec ep+ , vpPixelFormat = epPixelFormat ep+ , vpPreset = epPreset ep+ }++instance HasVideoParams AVEncodingParams where+ extractVideoParams ep = VideoParams+ { vpWidth = avepWidth ep+ , vpHeight = avepHeight ep+ , vpFps = avepFps ep+ , vpCodec = avepCodec ep+ , vpPixelFormat = avepPixelFormat ep+ , vpPreset = avepPreset ep+ }++class HasAudioParams a where+ extractAudioParams :: a -> AudioParams++instance HasAudioParams AEncodingParams where+ extractAudioParams ep = AudioParams+ { apChannelLayout = aepChannelLayout ep+ , apSampleRate = aepSampleRate ep+ , apSampleFormat = aepSampleFormat ep+ }++instance HasAudioParams AVEncodingParams where+ extractAudioParams ep = AudioParams+ { apChannelLayout = avepChannelLayout ep+ , apSampleRate = avepSampleRate ep+ , apSampleFormat = avepSampleFormat ep+ }+ -- | Use default parameters for a video of the given width and -- height, forcing the choice of the h264 encoder. defaultH264 :: CInt -> CInt -> EncodingParams-defaultH264 w h = EncodingParams w h 30 (Just avCodecIdH264) Nothing "medium" Nothing+defaultH264 w h =+ EncodingParams+ { epWidth = w+ , epHeight = h+ , epFps = 30+ , epCodec = (Just avCodecIdH264)+ , epPixelFormat = Nothing+ , epPreset = "medium"+ , epFormatName = Nothing+ } -- | Use default parameters for a video of the given width and -- height. The output format is determined by the output file name. defaultParams :: CInt -> CInt -> EncodingParams-defaultParams w h = EncodingParams w h 30 Nothing Nothing "" Nothing+defaultParams w h =+ EncodingParams+ { epWidth = w+ , epHeight = h+ , epFps = 30+ , epCodec = Nothing+ , epPixelFormat = Nothing+ , epPreset = ""+ , epFormatName = Nothing+ } -- | Determine if the bitwise intersection of two values is non-zero. checkFlag :: Bits a => a -> a -> Bool@@ -142,26 +271,31 @@ -- | 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) =+initStream ep oc = initVideoStream (extractVideoParams ep) oc++initVideoStream :: VideoParams -> AVFormatContext -> IO (AVStream, AVCodecContext)+initVideoStream vp _+ | (vpWidth vp `rem` 2, vpHeight vp `rem` 2) /= (0,0) = error "Video dimensions must be multiples of two"-initStream ep oc = do+initVideoStream vp oc = do -- Use the codec suggested by the output format, or override with -- the user's choice.- codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (epCodec ep)+ codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (vpCodec vp) cod <- avcodec_find_encoder codec when (getPtr cod == nullPtr) (error "Couldn't find encoder") st <- avformat_new_stream oc cod getNumStreams oc >>= setId st . subtract 1- let framePeriod = AVRational 1 (fromIntegral $ epFps ep)+ let framePeriod = AVRational 1 (fromIntegral $ vpFps vp)+ frameRate = AVRational (fromIntegral $ vpFps vp) 1 setTimeBase st framePeriod ctx <- getCodecContext st- setWidth ctx (epWidth ep)- setHeight ctx (epHeight ep)+ setWidth ctx (vpWidth vp)+ setHeight ctx (vpHeight vp) setTimeBase ctx framePeriod- setPixelFormat ctx $ case epPixelFormat ep of+ setFrameRate ctx frameRate+ setPixelFormat ctx $ case vpPixelFormat vp of Just fmt -> fmt Nothing | codec == avCodecIdRawvideo -> avPixFmtRgb24@@ -182,9 +316,9 @@ -- withCString (preset ep) $ \vStr -> -- av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx)) -- kStr vStr 0- when (not . null $ epPreset ep) . void $+ when (not . null $ vpPreset vp) . void $ withCString "preset" $ \kStr ->- withCString (epPreset ep) $ \vStr ->+ withCString (vpPreset vp) $ \vStr -> getPrivData ctx >>= \pd -> av_opt_set pd kStr vStr 0 rOpen <- open_codec ctx cod nullPtr@@ -192,20 +326,52 @@ return (st, ctx) +initAudioStream :: AudioParams+ -> AVFormatContext+ -> IO (AVStream, AVCodec, AVCodecContext)+initAudioStream params oc = do+ codecId <- getAudioCodecID =<< getOutputFormat oc+ print codecId+ cod <- avcodec_find_encoder codecId+ when (getPtr cod == nullPtr) (avError "Could not find audio codec")++ st <- avformat_new_stream oc cod+ getNumStreams oc >>= setId st . subtract 1+ setTimeBase st (AVRational 1 (apSampleRate params))++ ctx <- avcodec_alloc_context3 cod++ supportedSampleRates <- listSupportedSampleFormats cod+ let found = not (null supportedSampleRates)+ when (not found) $ avError "Could not find supported sample rate"+ -- TODO: check that these are valid+ setSampleFormat ctx (apSampleFormat params)+ setSampleRate ctx (apSampleRate params)++ setChannelLayout ctx (apChannelLayout params)++ runWithError "Could not open audio codec" (open_codec ctx cod nullPtr)++ codecParams <- getCodecParams st+ runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx)++ return (st, cod, 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.-initTempFrame :: EncodingParams -> AVPixelFormat -> IO AVFrame-initTempFrame ep fmt = do+initTempFrame :: VideoParams -> AVPixelFormat -> IO AVFrame+initTempFrame vp fmt = do frame <- frame_alloc_check setPixelFormat frame fmt- setWidth frame (epWidth ep)- setHeight frame (epHeight ep)+ setWidth frame (vpWidth vp)+ setHeight frame (vpHeight vp) setPts frame 0 -- For palettized images, we will provide our own buffer. if fmt == avPixFmtRgb8 || fmt == avPixFmtPal8- then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (epWidth ep)+ then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (vpWidth vp) when (r < 0) (error "Error filling temporary frame line sizes") else frame_get_buffer_check frame 32 return frame@@ -213,23 +379,21 @@ -- | Allocate an output context inferring the codec from the given -- file name. allocOutputContext :: Maybe String -> FilePath -> IO AVFormatContext-allocOutputContext outputFormat fname =- let- withFormat = case outputFormat of- Just f -> withCString f- Nothing -> (\f -> f nullPtr)- in do+allocOutputContext outputFormat fname = do+ let withFormat = case outputFormat of+ Just f -> withCString f+ Nothing -> (\f -> f nullPtr) oc <- alloca $ \ocTmp -> do- r <- withCString fname $ \fname' ->- withFormat $ \format ->- avformat_alloc_output_context2- ocTmp (AVOutputFormat nullPtr)- format fname'- when (r < 0)- (error "Couldn't allocate output format context")- peek ocTmp+ r <- withCString fname $ \fname' ->+ withFormat $ \format ->+ avformat_alloc_output_context2+ ocTmp (AVOutputFormat nullPtr)+ format fname'+ when (r < 0)+ (error "Couldn't allocate output format context")+ peek ocTmp when (getPtr oc == nullPtr)- (error "Couldn't allocate output AVFormatContext")+ (error "Couldn't allocate iutput AVFormatContext") return oc -- | Open the given file for writing.@@ -257,8 +421,8 @@ -- | 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) (error "Error writing header")+write_header_check oc =+ void $ runWithError "write header" (avformat_write_header oc nullPtr) -- | Write a packet to an output media file. write_frame_check :: AVFormatContext -> AVPacket -> IO ()@@ -275,8 +439,8 @@ -- | Quantize RGB24 pixels to the systematic RGB8 color palette. The -- image data has space for a palette appended to be compliant with -- 'av_image_fill_arrays''s expectations. This is slow.-palettizeRGB8 :: EncodingParams -> V.Vector CUChar -> V.Vector CUChar-palettizeRGB8 ep = \pix -> V.create $+palettizeRGB8 :: VideoParams -> V.Vector CUChar -> V.Vector CUChar+palettizeRGB8 vp = \pix -> V.create $ do let pix' = V.unsafeCast pix :: V.Vector (V3 CUChar) m <- VM.new (numPix + 1024) V.mapM_ (\i -> let p = searchPal $ fromIntegral <$> (pix' V.! i)@@ -284,7 +448,7 @@ (V.enumFromN 0 numPix) VM.set (VM.unsafeSlice numPix 1024 m) 0 return m- where numPix = fromIntegral $ epWidth ep * epHeight ep+ where numPix = fromIntegral $ vpWidth vp * vpHeight vp pal :: V.Vector (V3 CInt) pal = V.generate 256 $ \i' -> let i = fromIntegral i'@@ -296,16 +460,24 @@ -- | High quality dithered, median cut palette using 'palettize'. The -- result is packed such that the BGRA palette is laid out -- contiguously following the palettized image data.-palettizeJuicy :: EncodingParams -> V.Vector CUChar -> V.Vector CUChar-palettizeJuicy ep pix =+palettizeJuicy :: VideoParams -> V.Vector CUChar -> V.Vector CUChar+palettizeJuicy vp pix = let (pix', pal) = palettize (PaletteOptions MedianMeanCut doDither 256) (mkImage $ V.unsafeCast pix) pal' = V.map (\(V3 r g b) -> V4 b g r (255::CUChar))- (V.unsafeCast $ imageData pal)+ (V.unsafeCast $ imageData pal) in V.unsafeCast (imageData pix') V.++ V.unsafeCast pal'- where mkImage = Image (fromIntegral $ epWidth ep) (fromIntegral $ epHeight ep)- doDither = epPreset ep == "dither"+ where mkImage = Image (fromIntegral $ vpWidth vp) (fromIntegral $ vpHeight vp)+ doDither = vpPreset vp == "dither" +{-# DEPRECATED frameWriter "Please use videoWriter instead." #-}+frameWriter :: EncodingParams -> FilePath+ -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())+frameWriter ep fname = do+ let sp = JustVideo (extractVideoParams ep)+ writerContext <- avWriter (epFormatName ep) sp fname+ return (avwVideoWriter writerContext)+ -- | Open a target file for writing a video stream. The function -- returned may be used to write image frames (specified by a pixel -- format, resolution, and pixel data). If this function is applied to@@ -317,151 +489,305 @@ -- (i.e. those that are handled by @libswscaler@). Practically, this -- means that animated gif output only works if the source images are -- of the target resolution.-frameWriter :: EncodingParams -> FilePath+videoWriter :: EncodingParams -> FilePath -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())-frameWriter ep fname = do- oc <- allocOutputContext (epFormatName ep) fname- (st,ctx) <- initStream ep oc+videoWriter ep fname = do+ let sp = JustVideo (extractVideoParams ep)+ writerContext <- avWriter (epFormatName ep) sp fname+ return (avwVideoWriter writerContext) - dstFmt <- getPixelFormat ctx- dstFrame <- initTempFrame ep dstFmt- let dstInfo = ImageInfo (epWidth ep) (epHeight ep) dstFmt+data StreamParams =+ JustVideo VideoParams+ | JustAudio AudioParams+ | AudioVideo AudioParams VideoParams - -- Initialize the scaler that we use to convert RGB -> dstFmt- -- Note that libswscaler does not support Pal8 as an output format.- sws <- if dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8- then swsInit (ImageInfo (epWidth ep) (epHeight ep) avPixFmtRgb24)- dstInfo swsBilinear- >>= fmap Just . newIORef- else return Nothing+withVideoParams :: StreamParams -> a -> (VideoParams -> a) -> a+withVideoParams sp def f =+ case sp of+ JustVideo vp -> f vp+ AudioVideo _ vp -> f vp+ _ -> def - pkt <- AVPacket <$> av_malloc (fromIntegral packetSize)- setPts pkt 0+withAudioParams :: StreamParams -> a -> (AudioParams -> a) -> a+withAudioParams sp def f =+ case sp of+ JustAudio ap -> f ap+ AudioVideo ap _ -> f ap+ _ -> def - stIndex <- getStreamIndex st+-- | Open a target for writing an audio stream.+audioWriter :: AEncodingParams+ -> FilePath+ -> IO (Maybe AVCodecContext, Maybe AVFrame -> IO ())+audioWriter ep fname = do+ let sp = JustAudio (extractAudioParams ep)+ writerContext <- avWriter (aepFormatName ep) sp fname+ return (avwAudioCodecContext writerContext, avwAudioWriter writerContext)++data AVWriterContext = AVWriterContext+ { avwVideoCodecContext :: Maybe AVCodecContext+ , avwAudioCodecContext :: Maybe AVCodecContext+ , avwVideoWriter :: Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()+ , avwAudioWriter :: Maybe AVFrame -> IO ()+ }++-- | Open a target for writing a video and audio file.+audioVideoWriter :: AVEncodingParams -> FilePath -> IO AVWriterContext+audioVideoWriter ep fname = do+ let sp = AudioVideo (extractAudioParams ep) (extractVideoParams ep)+ avWriter (avepFormatName ep) sp fname++-- | For internal use only. Use 'videoWriter', 'audioWriter', or 'audioVideoWriter' instead.+avWriter :: Maybe String+ -> StreamParams+ -> FilePath+ -> IO AVWriterContext+avWriter outputFormat sp fname = do+ oc <- allocOutputContext outputFormat fname+ outputFormat <- getOutputFormat oc+ audioCodecId <- getAudioCodecID outputFormat+ videoCodecId <- getVideoCodecID outputFormat++ -- Initializing the streams needs to be done before opening the file+ -- and checking the header because it can modify fields that are used+ -- for time scaling so we have this rather ugly code.+ mVideoStream <- withVideoParams sp (return Nothing) $ \vp ->+ (Just <$> initVideoStream vp oc)+ mAudioStream <- withAudioParams sp (return Nothing) $ \ap ->+ (Just <$> initAudioStream ap oc) avio_open_check oc fname+ numStreams <- getNumStreams oc write_header_check oc - -- Frame number ioref. We use this to determine whether we should- -- increment the frame PTS; we only want to do this for frames after- -- the first one since we want the first frame PTS to be zero.- frameNum <- newIORef (0::Int)+ alreadyClosedRef <- newIORef False+ let writeClose = do+ alreadyClosed <- readIORef alreadyClosedRef+ when (not alreadyClosed) $ do+ write_trailer_check oc+ modifyIORef alreadyClosedRef (const True) - let framePeriod = AVRational 1 (fromIntegral $ epFps ep)+ initializeVideo :: AVStream+ -> AVCodecContext+ -> VideoParams+ -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())+ initializeVideo st ctx vp = do+ dstFmt <- getPixelFormat ctx+ dstFrame <- initTempFrame vp dstFmt+ let dstInfo = ImageInfo (vpWidth vp) (vpHeight vp) dstFmt - -- The stream time_base can be changed by the call to- -- 'write_header_check', so we read it back here to establish a way- -- of scaling the nominal, desired frame rate (given by- -- 'framePeriod') to the stream's time_base.- tb <- getTimeBase st+ -- Initialize the scaler that we use to convert RGB -> dstFmt+ -- Note that libswscaler does not support Pal8 as an output format.+ sws <- if dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8+ then swsInit (ImageInfo (vpWidth vp) (vpHeight vp) avPixFmtRgb24)+ dstInfo swsBilinear+ >>= fmap Just . newIORef+ else return Nothing++ pkt <- AVPacket <$> av_malloc (fromIntegral packetSize)+ setPts pkt 0++ stIndex <- getStreamIndex st++ -- Frame number ioref. We use this to determine whether we should+ -- increment the frame PTS; we only want to do this for frames after+ -- the first one since we want the first frame PTS to be zero.+ frameNum <- newIORef (0::Int)++ let framePeriod = AVRational 1 (fromIntegral $ vpFps vp)+ fps <- getFps ctx++ -- The stream time_base can be changed by the call to+ -- 'write_header_check', so we read it back here to establish a way+ -- of scaling the nominal, desired frame rate (given by+ -- 'framePeriod') to the stream's time_base.+ tb <- getTimeBase st #if LIBAVFORMAT_VERSION_MAJOR < 57- isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags)+ isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) #endif - let checkPalCompat- | dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 = const True- | otherwise = \(srcFmt, V2 srcW srcH, _) ->- srcFmt == avPixFmtRgb24 &&- srcW == epWidth ep &&- srcH == epHeight ep+ let checkPalCompat+ | dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 = const True+ | otherwise = \(srcFmt, V2 srcW srcH, _) ->+ srcFmt == avPixFmtRgb24 &&+ srcW == vpWidth vp &&+ srcH == vpHeight vp - palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy ep- | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 ep- | otherwise = Nothing- frameTime = av_rescale_q 1 framePeriod tb- resetPacket = do init_packet pkt- setData pkt nullPtr- setSize pkt 0- writePacket = do setStreamIndex pkt stIndex- write_frame_check oc pkt+ palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy vp+ | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 vp+ | otherwise = Nothing+ frameTime = av_rescale_q 1 framePeriod tb+ resetPacket = do init_packet pkt+ setPktData pkt nullPtr+ setSize pkt 0+ writePacket = do setStreamIndex pkt stIndex+ write_frame_check oc pkt - copyDstData (_,_,pixels) =- void . V.unsafeWith pixels $ \ptr ->- av_image_fill_arrays (castPtr $ hasData dstFrame)- (hasLineSize dstFrame)- (castPtr ptr)- dstFmt- (epWidth ep)- (epHeight ep)- 1+ copyDstData (_,_,pixels) =+ void . V.unsafeWith pixels $ \ptr ->+ av_image_fill_arrays (castPtr $ hasData dstFrame)+ (hasLineSize dstFrame)+ (castPtr ptr)+ dstFmt+ (vpWidth vp)+ (vpHeight vp)+ 1 - scaleToDst sws' img = void $ swsScale sws' img dstFrame- fillDst = maybe copyDstData scaleToDst+ scaleToDst sws' img = void $ swsScale sws' img dstFrame+ fillDst = maybe copyDstData scaleToDst - -- | Gets the PTS to be used for the current frame by reading the- -- PTS from dstFrame. If the current frame is the first frame- -- (zero), the existing timestamp is left unmodified. Otherwise it- -- is incremented by frameTime.- --- -- This also increments the current frame number stored in the- -- frameNum IORef so the caller needn't worry about it.- getCurrentFrameTimestamp = do- curFrame <- readIORef frameNum- ts <- case curFrame == 0 of- True -> getPts dstFrame- False -> (+ frameTime) <$> getPts dstFrame- modifyIORef frameNum (+1)- return ts+ -- | Gets the PTS to be used for the current frame by reading the+ -- PTS from dstFrame. If the current frame is the first frame+ -- (zero), the existing timestamp is left unmodified. Otherwise it+ -- is incremented by frameTime.+ --+ -- This also increments the current frame number stored in the+ -- frameNum IORef so the caller needn't worry about it.+ getCurrentFrameTimestamp = do+ curFrame <- readIORef frameNum+ ts <- case curFrame == 0 of+ True -> getPts dstFrame+ False -> (+ frameTime) <$> getPts dstFrame+ modifyIORef frameNum (+1)+ return ts #if LIBAVFORMAT_VERSION_MAJOR < 57- addRaw Nothing = return ()- addRaw (Just (_, _, pixels)) =- do resetPacket- getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey)- --setSize pkt (fromIntegral $ V.length pixels)- setSize pkt (fromIntegral pictureSize)- timeStamp <- getCurrentFrameTimestamp- setPts dstFrame timeStamp- setPts pkt timeStamp- -- getPts dstFrame >>= setDts pkt- V.unsafeWith pixels $ \ptr -> do- setData pkt (castPtr ptr)- writePacket+ addRaw Nothing = return ()+ addRaw (Just (_, _, pixels)) =+ do resetPacket+ getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey)+ --setSize pkt (fromIntegral $ V.length pixels)+ setSize pkt (fromIntegral pictureSize)+ timeStamp <- getCurrentFrameTimestamp+ setPts dstFrame timeStamp+ setPts pkt timeStamp+ -- getPts dstFrame >>= setDts pkt+ V.unsafeWith pixels $ \ptr -> do+ setData pkt (castPtr ptr)+ writePacket #endif- addEncoded Nothing = do resetPacket- encode_video_check ctx pkt Nothing >>=- flip when (writePacket >> addEncoded Nothing)- addEncoded (Just srcImg@(srcFmt, V2 srcW srcH, pixels)) =- do resetPacket- when (not $ checkPalCompat srcImg)- (error $- unlines [ "Palettized output requires source images to be the "- , "same resolution as the output video" ])- let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer- sws' <- for sws $ \sPtr -> do- s <- readIORef sPtr- s' <- swsReset s (ImageInfo srcW srcH srcFmt) dstInfo- swsBilinear- writeIORef sPtr s'- return s'- fillDst sws' (srcFmt, V2 srcW srcH, pixels')- timeStamp <- getCurrentFrameTimestamp- setPts dstFrame timeStamp- encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket- -- Make sure the GC hasn't clobbered our palettized pixel data- let (fp,_,_) = V.unsafeToForeignPtr pixels'- touchForeignPtr fp+ addEncoded Nothing = do resetPacket+ encode_video_check ctx pkt Nothing >>=+ flip when (writePacket >> addEncoded Nothing)+ addEncoded (Just srcImg@(srcFmt, V2 srcW srcH, pixels)) =+ do resetPacket+ when (not $ checkPalCompat srcImg)+ (error $+ unlines [ "Palettized output requires source images to be the "+ , "same resolution as the output video" ])+ let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer+ sws' <- for sws $ \sPtr -> do+ s <- readIORef sPtr+ s' <- swsReset s (ImageInfo srcW srcH srcFmt) dstInfo+ swsBilinear+ writeIORef sPtr s'+ return s'+ timeStamp <- getCurrentFrameTimestamp+ setPts dstFrame timeStamp+ fillDst sws' (srcFmt, V2 srcW srcH, pixels')+ encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket+ -- Make sure the GC hasn't clobbered our palettized pixel data+ let (fp,_,_) = V.unsafeToForeignPtr pixels'+ touchForeignPtr fp #if LIBAVFORMAT_VERSION_MAJOR < 57- addFrame = if isRaw then addRaw else addEncoded+ addFrame = if isRaw then addRaw else addEncoded #else- addFrame = addEncoded+ addFrame = addEncoded #endif- go Nothing = do addFrame Nothing- write_trailer_check oc- _ <- codec_close ctx- with dstFrame av_frame_free- av_free (getPtr pkt)- avio_close_check oc- avformat_free_context oc- go img@(Just _) = addFrame img- return go+ go Nothing = do addFrame Nothing+ writeClose+ _ <- codec_close ctx+ with dstFrame av_frame_free+ av_free (getPtr pkt)+ avio_close_check oc+ avformat_free_context oc+ go img@(Just _) = addFrame img+ return go + initializeAudio :: AVStream+ -> AVCodec+ -> AVCodecContext+ -> IO (Maybe AVFrame -> IO ())+ initializeAudio st codec ctx = do+ if audioCodecId /= avCodecIdNone+ then do+ pkt <- av_packet_alloc+ init_packet pkt++ frameNum <- newIORef (0::Int)+ timeBase <- getTimeBase ctx++ lastPts <- newIORef 0++ let read_pkts = do+ ret <- avcodec_receive_packet ctx pkt+ -- TODO: Distinguish between temp and permanent errors with EAGAIN+ if ret /= 0+ then return ()+ else do+ timeBase2 <- getTimeBase st+ packet_rescale_ts pkt timeBase timeBase2+ setStreamIndex pkt =<< getStreamIndex st+ -- TODO: Not sure this pts will be exactly accurate.+ -- Also, we need to set duration too because it doesn't seem to be set.+ setPts pkt =<< readIORef lastPts+ runWithError "Error while writing audio frame"+ (av_interleaved_write_frame oc pkt)+ return ()+ writeAudioFrame :: Maybe AVFrame -> IO ()+ writeAudioFrame Nothing = do+ read_pkts+ writeClose+ codec_close ctx+ return ()+ writeAudioFrame (Just frame) = writeAudioFrame' frame++ writeAudioFrame' :: AVFrame -> IO ()+ writeAudioFrame' frame = do+ numSamples <- getNumSamples frame+ sampleRate <- getSampleRate ctx++ onGoingSampleCount <- readIORef frameNum+ let samplesCount = av_rescale_q (fromIntegral onGoingSampleCount)+ (AVRational 1 sampleRate) timeBase+ setPts frame (av_rescale_q samplesCount (AVRational 1 sampleRate) timeBase)+ newPts <- getPts frame+ modifyIORef lastPts (const newPts)+ modifyIORef frameNum (+ fromIntegral numSamples)++ runWithError "Error encoding audio"+ (avcodec_send_frame ctx frame)+ read_pkts+ return writeAudioFrame+ else+ return $ \_ -> return ()++ videoWriter <- case mVideoStream of+ Just (vs, ctx) ->+ withVideoParams sp (return (\_ -> return ()))+ (initializeVideo vs ctx)+ Nothing -> return (\_ -> return ())+ audioWriter <- case mAudioStream of+ Just (as, codec, ctx) ->+ withAudioParams sp (return $ \_ -> return ())+ (const (initializeAudio as codec ctx))+ Nothing -> return $ \_ -> return ()++ return $ AVWriterContext+ { avwVideoCodecContext = snd <$> mVideoStream+ , avwAudioCodecContext = (\(_, _, ctx) -> ctx) <$> mAudioStream+ , avwVideoWriter = videoWriter+ , avwAudioWriter = audioWriter+ }+ -- | 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' (i.e. the same resolution as the -- output video). If this function is applied to 'Nothing', then the -- output stream is closed. Note that 'Nothing' /must/ be provided to--- properly terminate video encoding.+-- properly terminate video encoding. Throws an error if you do not+-- provide a 'EncodingParams' without 'VideoParams' frameWriterRgb :: EncodingParams -> FilePath -> IO (Maybe (Vector CUChar) -> IO ())-frameWriterRgb ep f = (. fmap aux) <$> frameWriter ep f- where aux pixels = (avPixFmtRgb24, V2 (epWidth ep) (epHeight ep), pixels)+frameWriterRgb ep f = do+ let aux pixels = (avPixFmtRgb24, V2 (epWidth ep) (epHeight ep), pixels)+ videoWriter <- frameWriter ep f+ return $ \pix -> videoWriter (aux <$> pix)
src/Codec/FFmpeg/Enums.hsc view
@@ -319,14 +319,11 @@ , AV_CODEC_ID_DSD_MSBF\ , AV_CODEC_ID_DSD_LSBF_PLANAR\ , AV_CODEC_ID_DSD_MSBF_PLANAR\- , AV_CODEC_ID_4GV--- -- \- -- , AV_CODEC_ID_INTERPLAY_ACM\- -- , AV_CODEC_ID_XMA1\- -- , AV_CODEC_ID_XMA2\- -- , AV_CODEC_ID_DST+ , AV_CODEC_ID_4GV\+ , AV_CODEC_ID_INTERPLAY_ACM\+ , AV_CODEC_ID_XMA1\+ , AV_CODEC_ID_XMA2\+ , AV_CODEC_ID_DST newtype SwsAlgorithm = SwsAlgorithm CUInt deriving (Eq, Show, Storable)
src/Codec/FFmpeg/Internal/Debug.hsc view
@@ -69,3 +69,9 @@ -- | Get the name of a codec. debugCodecName :: AVCodecID -> IO String debugCodecName = avcodec_get_name >=> peekCString++foreign import ccall "av_get_sample_fmt_name"+ av_get_sample_fmt_name :: AVSampleFormat -> IO CString++debugSampleFmtName :: AVSampleFormat -> IO String+debugSampleFmtName = av_get_sample_fmt_name >=> peekCString
src/Codec/FFmpeg/Juicy.hs view
@@ -158,8 +158,16 @@ -- images are of the target resolution. imageWriter :: forall p. JuicyPixelFormat p => EncodingParams -> FilePath -> IO (Maybe (Image p) -> IO ())-imageWriter ep f = (. fmap aux) <$> frameWriter ep f- where aux img = let w = fromIntegral $ imageWidth img- h = fromIntegral $ imageHeight img- p = V.unsafeCast $ imageData img- in (juicyPixelFormat ([]::[p]), V2 w h, p)+imageWriter ep f = do+ videoWriter <- frameWriter ep f+ return $ (. fmap fromJuciy) videoWriter++-- | Util function to convert a JuicyPixels image to the same structure+-- used by 'frameWriter'+fromJuciy :: forall p. JuicyPixelFormat p+ => Image p -> (AVPixelFormat, V2 CInt, V.Vector CUChar)+fromJuciy img = (juicyPixelFormat ([]::[p]), V2 w h, p)+ where+ w = fromIntegral $ imageWidth img+ h = fromIntegral $ imageHeight img+ p = V.unsafeCast $ imageData img
src/Codec/FFmpeg/Probe.hsc view
@@ -173,3 +173,4 @@ foreign import ccall "av_dict_get" av_dict_get :: AVDictionary -> CString -> Ptr () -> CInt -> IO (Ptr ())+
+ src/Codec/FFmpeg/Resampler.hs view
@@ -0,0 +1,149 @@+module Codec.FFmpeg.Resampler where++import Codec.FFmpeg.Common+import Codec.FFmpeg.Enums+import Codec.FFmpeg.Types+import Control.Concurrent.STM.TChan+import Control.Monad (void, when)+import Control.Monad.STM+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable++foreign import ccall "swr_get_delay"+ swr_get_delay :: SwrContext -> CLong -> IO CLong++foreign import ccall "swr_convert"+ swr_convert :: SwrContext -> Ptr (Ptr CUChar) -> CInt+ -> Ptr (Ptr CUChar) -> CInt -> IO CInt++foreign import ccall "swr_get_out_samples"+ swr_get_out_samples :: SwrContext -> CInt -> IO CInt++data AudioParams = AudioParams+ { apChannelLayout :: CULong+ , apSampleRate :: CInt+ , apSampleFormat :: AVSampleFormat+ }++makeResampler :: AVCodecContext+ -> AudioParams+ -> AudioParams+ -> IO (AVFrame -> IO (), IO (Maybe AVFrame))+makeResampler ctx inParams outParams = do+ swr <- initSwrContext inParams outParams++ frameChan <- newTChanIO++ let writeFrame frame = do+ srcSamples <- getNumSamples frame+ if srcSamples == 0+ then return ()+ else do+ srcRate <- getSampleRate frame+ delay <- swr_get_delay swr (fromIntegral srcRate)+ let dstSamples = av_rescale_rnd+ (delay + fromIntegral srcSamples)+ (fromIntegral (apSampleRate outParams))+ (fromIntegral srcRate) avRoundUp+ srcData = castPtr (hasData frame)+ dstDataPtr <- malloc+ lineSize <- malloc+ dstChannelCount <- av_get_channel_layout_nb_channels+ (apChannelLayout outParams)+ runWithError "Could not alloc samples"+ (av_samples_alloc_array_and_samples dstDataPtr lineSize+ dstChannelCount (fromIntegral dstSamples)+ (apSampleFormat outParams) 0)+ dstData <- peek dstDataPtr+ runWithError "Error converting samples"+ (swr_convert swr nullPtr 0 srcData srcSamples)++ frameSize <- getFrameSize ctx+ let convertLoop = do+ outSamples <- swr_get_out_samples swr 0+ if outSamples < frameSize * dstChannelCount+ then return ()+ else do+ frame <- allocAudioFrame ctx+ outSamples <- swr_convert swr (castPtr $ hasData frame)+ frameSize nullPtr 0++ atomically $ writeTChan frameChan frame+ convertLoop++ convertLoop+ free dstData+ free lineSize+ return ()++ allocAudioFrame :: AVCodecContext -> IO AVFrame+ allocAudioFrame ctx = do+ frame <- av_frame_alloc+ when (getPtr frame == nullPtr)+ (error "Error allocating an audio frame")++ setFormat frame . getSampleFormatInt =<< getSampleFormat ctx+ setChannelLayout frame =<< getChannelLayout ctx+ setSampleRate frame =<< getSampleRate ctx+ fs <- (do fs <- getFrameSize ctx+ if fs == 0+ then return 1000+ else return fs)+ setNumSamples frame fs++ runWithError "Error allocating an audio buffer"+ (av_frame_get_buffer frame 0)+ return frame++ readFrame = do+ mFrame <- atomically $ tryReadTChan frameChan+ case mFrame of+ Nothing -> return Nothing+ Just _ -> return mFrame++ return (writeFrame, readFrame)++initSwrContext :: AudioParams -> AudioParams -> IO SwrContext+initSwrContext inParams outParams = do+ swr <- swr_alloc+ when (getPtr swr == nullPtr) (error "Could not allocate resampler context")+ let set_int str i = do+ cStr <- newCString str+ av_opt_set_int (getPtr swr) cStr (fromIntegral i) 0+ free cStr+ set_sample_fmt str fmt = do+ cStr <- newCString str+ av_opt_set_sample_fmt (getPtr swr) cStr fmt 0+ free cStr++ -- set_int "in_channel_count" (aoChannelCount inParams)+ set_int "in_channel_layout" (apChannelLayout inParams)+ set_int "in_sample_rate" (apSampleRate inParams)+ set_sample_fmt "in_sample_fmt" (apSampleFormat inParams)+ -- set_int "out_channel_count" (aoChannelCount outParams)+ set_int "out_channel_layout" (apChannelLayout inParams)+ set_int "out_sample_rate" (apSampleRate outParams)+ set_sample_fmt "out_sample_fmt" (apSampleFormat outParams)++ void $ runWithError "Failed to initialize the resampling context" (swr_init swr)++ let get_int str = do+ cStr <- newCString str+ p <- malloc+ r <- av_opt_get_int (getPtr swr) cStr 0 p+ v <- peek p+ free p+ return v+ get_sample_fmt str = do+ cStr <- newCString str+ p <- malloc+ r <- av_opt_get_sample_fmt (getPtr swr) cStr 0 p+ fmt <- peek p+ free p+ return fmt++ return swr
src/Codec/FFmpeg/Scaler.hs view
@@ -76,7 +76,7 @@ swsStrides img $ \strides -> sliceHeight img $ \height -> k planes strides height- + -- | @swsScale ctx src dst@ scales the entire @src@ image to @dst@ -- using the previously initialized @ctx@. swsScale :: (SwsCompatible src, SwsCompatible dst)
src/Codec/FFmpeg/Types.hsc view
@@ -8,11 +8,14 @@ import Foreign.C.Types import Foreign.Ptr import Foreign.Storable+import Foreign.Marshal.Alloc (malloc) #include <libavcodec/avcodec.h> #include <libavformat/avformat.h>+#include <libavutil/audio_fifo.h> #include <libavutil/avutil.h> #include <libswscale/swscale.h>+#include <libswresample/swresample.h> #include "hscMacros.h" #include "nameCompat.h" @@ -68,9 +71,12 @@ newtype AVCodecContext = AVCodecContext (Ptr ()) deriving (Storable, HasPtr) +foreign import ccall "avcodec_alloc_context3"+ avcodec_alloc_context3 :: AVCodec -> IO AVCodecContext+ #mkField BitRate, CInt-#hasField AVCodecContext, BitRate, bit_rate +#mkField SampleFormat, AVSampleFormat #mkField Width, CInt #mkField Height, CInt #mkField TimeBase, AVRational@@ -81,7 +87,13 @@ #mkField PrivData, (Ptr ()) #mkField TicksPerFrame, CInt #mkField RawAspectRatio, AVRational+#mkField SampleRate, CInt+#mkField ChannelLayout, CULong+#mkField Channels, CInt+#mkField FrameSize, CInt+#mkField FrameRate, AVRational +#hasField AVCodecContext, BitRate, bit_rate #hasField AVCodecContext, Width, width #hasField AVCodecContext, Height, height #hasField AVCodecContext, TimeBase, time_base@@ -92,6 +104,12 @@ #hasField AVCodecContext, PrivData, priv_data #hasField AVCodecContext, TicksPerFrame, ticks_per_frame #hasField AVCodecContext, RawAspectRatio, sample_aspect_ratio+#hasField AVCodecContext, SampleRate, sample_rate+#hasField AVCodecContext, ChannelLayout, channel_layout+#hasField AVCodecContext, Channels, channels+#hasField AVCodecContext, SampleFormat, sample_fmt+#hasField AVCodecContext, FrameSize, frame_size+#hasField AVCodecContext, FrameRate, framerate getFps :: (HasTimeBase a, HasTicksPerFrame a) => a -> IO CDouble getFps x = do@@ -110,40 +128,67 @@ setAspectRatio x Nothing = setRawAspectRatio x (AVRational 0 1) setAspectRatio x (Just ratio) = setRawAspectRatio x ratio -newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr)+newtype AVCodecParameters = AVCodecParameters (Ptr ()) deriving (Storable, HasPtr) +foreign import ccall "avcodec_parameters_from_context"+ avcodec_parameters_from_context :: AVCodecParameters+ -> AVCodecContext+ -> IO CInt++newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) #mkField Id, CInt #mkField CodecContext, AVCodecContext #mkField StreamIndex, CInt+#mkField CodecParams, AVCodecParameters #hasField AVStream, Id, id #hasField AVStream, TimeBase, time_base #hasField AVStream, CodecContext, codec #hasField AVStream, StreamIndex, index+#hasField AVStream, CodecParams, codecpar newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) #mkField LongName, CString #mkField Name, CString #mkField PixelFormats, (Ptr AVPixelFormat)+#mkField SampleFormats, (Ptr AVSampleFormat)+#mkField ChannelLayouts, (Ptr CULong)+#mkField SupportedSampleRates, (Ptr CInt)+#mkField Capabilities, CInt #hasField AVCodec, LongName, long_name #hasField AVCodec, Name, name #hasField AVCodec, CodecID, id #hasField AVCodec, PixelFormats, pix_fmts+#hasField AVCodec, SampleFormats, sample_fmts+#hasField AVCodec, ChannelLayouts, channel_layouts+#hasField AVCodec, SupportedSampleRates, supported_samplerates+#hasField AVCodec, Capabilities, capabilities newtype AVDictionary = AVDictionary (Ptr ()) deriving (Storable, HasPtr) newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr) #mkField Pts, CLong #mkField PktPts, CLong #mkField LineSize, CInt+#mkField Data, (Ptr (Ptr ()))+#mkField ExtendedData, (Ptr (Ptr ()))+#mkField NumSamples, CInt+#mkField Format, CInt #hasField AVFrame, PixelFormat, format+#hasField AVFrame, SampleFormat, 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+#hasField AVFrame, ExtendedData, extended_data+#hasField AVFrame, NumSamples, nb_samples+#hasField AVFrame, Format, format+#hasField AVFrame, Channels, channels+#hasField AVFrame, ChannelLayout, channel_layout+#hasField AVFrame, SampleRate, sample_rate newtype AVPicture = AVPicture (Ptr ()) deriving (Storable, HasPtr) #hasField AVPicture, Data, data@@ -152,8 +197,10 @@ newtype AVOutputFormat = AVOutputFormat (Ptr ()) deriving (Storable, HasPtr) #mkField FormatFlags, FormatFlag #mkField VideoCodecID, AVCodecID+#mkField AudioCodecID, AVCodecID #hasField AVOutputFormat, FormatFlags, flags #hasField AVOutputFormat, VideoCodecID, video_codec+#hasField AVOutputFormat, AudioCodecID, audio_codec newtype AVInputFormat = AVInputFormat (Ptr ()) deriving (Storable, HasPtr) newtype AVClass = AVClass (Ptr ()) deriving (Storable, HasPtr)@@ -181,17 +228,19 @@ newtype AVIOContext = AVIOContext (Ptr ()) deriving (Storable, HasPtr) newtype AVPacket = AVPacket (Ptr ()) deriving (Storable, HasPtr)-#mkField Data, (Ptr ())+#mkField PktData, (Ptr ()) #mkField Size, CInt #mkField PacketFlags, PacketFlag #mkField Dts, CLong+#mkField Duration, CULong -#hasField AVPacket, Data, data+#hasField AVPacket, PktData, data #hasField AVPacket, Size, size #hasField AVPacket, PacketFlags, flags #hasField AVPacket, StreamIndex, stream_index #hasField AVPacket, Pts, pts #hasField AVPacket, Dts, dts+#hasField AVPacket, Duration, duration -- | @sizeof@ the 'AVPacket' structure in bytes. packetSize :: Int@@ -200,12 +249,58 @@ pictureSize :: Int pictureSize = #size AVPicture +newtype SwrContext = SwrContext (Ptr ()) deriving (Storable, HasPtr)++newtype AVAudioFifo = AVAudioFifo (Ptr ()) deriving (Storable, HasPtr)++foreign import ccall "av_samples_alloc_array_and_samples"+ av_samples_alloc_array_and_samples :: Ptr (Ptr (Ptr CUChar))+ -> Ptr CInt+ -> CInt+ -> CInt+ -> AVSampleFormat+ -> CInt+ -> IO CInt++foreign import ccall "av_audio_fifo_free"+ av_audio_fifo_free :: AVAudioFifo -> IO ()++foreign import ccall "av_audio_fifo_alloc"+ av_audio_fifo_alloc :: AVSampleFormat -> CInt -> CInt -> IO AVAudioFifo++foreign import ccall "av_audio_fifo_realloc"+ av_audio_fifo_realloc :: AVAudioFifo -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_write"+ av_audio_fifo_write :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_peek"+ av_audio_fifo_peek :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_peek_at"+ av_audio_fifo_peek_at :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_read"+ av_audio_fifo_read :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_drain"+ av_audio_fifo_drain :: AVAudioFifo -> CInt -> IO CInt++foreign import ccall "av_audio_fifo_reset"+ av_audio_fifo_reset :: AVAudioFifo -> IO ()++foreign import ccall "av_audio_fifo_size"+ av_audio_fifo_size :: AVAudioFifo -> IO CInt++foreign import ccall "av_audio_fifo_space"+ av_audio_fifo_space :: AVAudioFifo -> IO CInt+ -- * Types with Haskell equivalents data AVRational = AVRational { numerator :: CInt , denomenator :: CInt } deriving Show --- | FFmpeg often uses 0 to mean "unknown"; use 'Nothing' instead.+-- | FFmpeg often uses 0 to mean "unknown"; use 'Nothing' instead.VRational nonZeroAVRational :: AVRational -> Maybe AVRational nonZeroAVRational (AVRational 0 _) = Nothing nonZeroAVRational ratio = Just ratio@@ -230,6 +325,21 @@ 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)++foreign import ccall "av_packet_rescale_ts"+ av_packet_rescale_ts :: AVPacket -> Ptr AVRational -> Ptr AVRational -> IO ()++foreign import ccall "av_packet_unref"+ av_packet_unref :: AVPacket -> IO ()++packet_rescale_ts :: AVPacket -> AVRational -> AVRational -> IO ()+packet_rescale_ts packet rat1 rat2 = do+ ptr1 <- malloc+ ptr2 <- malloc+ poke ptr1 rat1+ poke ptr2 rat2+ av_packet_rescale_ts packet ptr1 ptr2+ #if LIBAVFORMAT_VERSION_MAJOR < 57 data AVFrac = AVFrac { fracVal :: CLong