diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/demo/AudioExtract.hs b/demo/AudioExtract.hs new file mode 100644 --- /dev/null +++ b/demo/AudioExtract.hs @@ -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" diff --git a/demo/AudioSin.hs b/demo/AudioSin.hs new file mode 100644 --- /dev/null +++ b/demo/AudioSin.hs @@ -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 diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -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." diff --git a/demo/Transcode.hs b/demo/Transcode.hs --- a/demo/Transcode.hs +++ b/demo/Transcode.hs @@ -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) diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -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 diff --git a/src/Codec/FFmpeg.hs b/src/Codec/FFmpeg.hs --- a/src/Codec/FFmpeg.hs +++ b/src/Codec/FFmpeg.hs @@ -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(..)) diff --git a/src/Codec/FFmpeg/AudioStream.hs b/src/Codec/FFmpeg/AudioStream.hs new file mode 100644 --- /dev/null +++ b/src/Codec/FFmpeg/AudioStream.hs @@ -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 + diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -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 + ) diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -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. diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -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) diff --git a/src/Codec/FFmpeg/Enums.hsc b/src/Codec/FFmpeg/Enums.hsc --- a/src/Codec/FFmpeg/Enums.hsc +++ b/src/Codec/FFmpeg/Enums.hsc @@ -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) diff --git a/src/Codec/FFmpeg/Internal/Debug.hsc b/src/Codec/FFmpeg/Internal/Debug.hsc --- a/src/Codec/FFmpeg/Internal/Debug.hsc +++ b/src/Codec/FFmpeg/Internal/Debug.hsc @@ -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 diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -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 diff --git a/src/Codec/FFmpeg/Probe.hsc b/src/Codec/FFmpeg/Probe.hsc --- a/src/Codec/FFmpeg/Probe.hsc +++ b/src/Codec/FFmpeg/Probe.hsc @@ -173,3 +173,4 @@ foreign import ccall "av_dict_get" av_dict_get :: AVDictionary -> CString -> Ptr () -> CInt -> IO (Ptr ()) + diff --git a/src/Codec/FFmpeg/Resampler.hs b/src/Codec/FFmpeg/Resampler.hs new file mode 100644 --- /dev/null +++ b/src/Codec/FFmpeg/Resampler.hs @@ -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 diff --git a/src/Codec/FFmpeg/Scaler.hs b/src/Codec/FFmpeg/Scaler.hs --- a/src/Codec/FFmpeg/Scaler.hs +++ b/src/Codec/FFmpeg/Scaler.hs @@ -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) diff --git a/src/Codec/FFmpeg/Types.hsc b/src/Codec/FFmpeg/Types.hsc --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -8,11 +8,14 @@ import Foreign.C.Types import Foreign.Ptr import Foreign.Storable +import Foreign.Marshal.Alloc (malloc) #include #include +#include #include #include +#include #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