From b05af29c01bcbc4dc482763183304270b314642b Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Mon, 4 Mar 2024 08:22:26 +0000 Subject: [PATCH 1/9] Migration to latest libav* packages on debian 12.4 --- .gitignore | 3 + demo/Main.hs | 38 +++++----- ffmpeg-light.cabal | 7 +- src/Codec/FFmpeg.hs | 8 +- src/Codec/FFmpeg/AudioStream.hs | 4 +- src/Codec/FFmpeg/Common.hsc | 34 ++++++--- src/Codec/FFmpeg/Decode.hs | 110 +++++++++++++++------------- src/Codec/FFmpeg/Encode.hsc | 42 +++++++---- src/Codec/FFmpeg/Enums.hsc | 40 ++++++++++ src/Codec/FFmpeg/Internal/Debug.hsc | 1 - src/Codec/FFmpeg/Juicy.hs | 54 ++++++++++---- src/Codec/FFmpeg/Probe.hsc | 60 ++++++++++++--- src/Codec/FFmpeg/Resampler.hs | 21 ++---- src/Codec/FFmpeg/Types.hsc | 63 +++++++++++----- stack.yaml | 41 ----------- stack.yaml.lock | 14 ++-- 16 files changed, 328 insertions(+), 212 deletions(-) delete mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index e92aab8..ef71494 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,6 @@ dist /.cabbages /TAGS .stack-work +dist-newstyle +cabal.project.local + diff --git a/demo/Main.hs b/demo/Main.hs index 9faafbb..243b877 100644 --- a/demo/Main.hs +++ b/demo/Main.hs @@ -11,7 +11,7 @@ import Control.Monad (unless) -- The example used in the README firstFrame :: IO (Maybe DynamicImage) firstFrame = do initFFmpeg - (getFrame, cleanup) <- imageReader (File "myVideo.mov") + (getFrame, cleanup, maybeMetadata) <- imageReader (File "myVideo.mov") (fmap ImageRGB8 <$> getFrame) <* cleanup -- | Generate a video that pulses from light to dark. @@ -34,27 +34,29 @@ pulseVid = -- | Generate a video that fades from white to gray to white. testEncode :: IO () -testEncode = initFFmpeg >> pulseVid >> putStrLn "All done!" +testEncode = initFFmpeg >> setLogLevel avLogTrace >> pulseVid >> putStrLn "All done!" -- | Decoding example. Try changing 'ImageRGB8' to 'ImageY8' in the -- 'savePngImage' lines to automatically decode to grayscale images! testDecode :: FilePath -> IO () testDecode vidFile = - do initFFmpeg - (getFrame, cleanup) <- imageReaderTime (File vidFile) - frame1 <- getFrame - case frame1 of - Just (avf,ts) -> do putStrLn $ "Frame at "++show ts - savePngImage "frame1.png" (ImageRGB8 avf) - Nothing -> putStrLn "No frame for me :(" - replicateM_ 299 getFrame - frame2 <- getFrame - case frame2 of - Just (avf,ts) -> do putStrLn $ "Frame at "++show ts - savePngImage "frame2.png" (ImageRGB8 avf) - Nothing -> putStrLn "No frame for me :(" - cleanup - putStrLn "All done!" + do + initFFmpeg + setLogLevel avLogTrace + (getFrame, cleanup, maybeMetadata) <- imageReaderTime (File vidFile) + frame1 <- getFrame + case frame1 of + Just (avf,ts) -> do putStrLn $ "Frame at "++show ts + savePngImage "frame1.png" (ImageRGB8 avf) + Nothing -> putStrLn "No frame for me :(" + replicateM_ 299 getFrame + frame2 <- getFrame + case frame2 of + Just (avf,ts) -> do putStrLn $ "Frame at "++show ts + savePngImage "frame2.png" (ImageRGB8 avf) + Nothing -> putStrLn "No frame for me :(" + cleanup + putStrLn "All done!" -- | @loopFor timeSpan action@ repeats @action@ until at least @timeSpan@ -- seconds have elapsed. @@ -71,7 +73,7 @@ testCamera = do initFFmpeg -- Defaults to quiet (minimal) logging -- setLogLevel avLogInfo -- Restore standard ffmpeg logging - (getFrame, cleanup) <- imageReader $ + (getFrame, cleanup, maybeMetadata) <- imageReader $ case Info.os of "linux" -> let cfg = CameraConfig (Just 30) Nothing (Just "mjpeg") diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal index 81bd966..f207c65 100644 --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -1,5 +1,5 @@ name: ffmpeg-light -version: 0.14.1 +version: 0.15.0 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -28,7 +28,7 @@ category: Codec build-type: Simple extra-source-files: src/hscMacros.h, src/nameCompat.h, CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.1 || == 9.6.11 +tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.11 source-repository head type: git @@ -87,7 +87,8 @@ library transformers >= 0.4.1 && < 0.7, mtl >= 2.2.1 && < 2.4, JuicyPixels >= 3.1 && < 3.4, - bytestring + bytestring, + containers pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice, libswresample diff --git a/src/Codec/FFmpeg.hs b/src/Codec/FFmpeg.hs index 226993c..6192c9f 100644 --- a/src/Codec/FFmpeg.hs +++ b/src/Codec/FFmpeg.hs @@ -19,13 +19,9 @@ import Codec.FFmpeg.Enums import Codec.FFmpeg.Juicy import Codec.FFmpeg.Resampler import Codec.FFmpeg.Types +import Codec.FFmpeg.Common (avdevice_register_all) import Foreign.C.Types (CInt(..)) -foreign import ccall "av_register_all" av_register_all :: IO () -foreign import ccall "avdevice_register_all" avdevice_register_all :: IO () - --- foreign import ccall "avcodec_register_all" avcodec_register_all :: IO ( - foreign import ccall "av_log_set_level" av_log_set_level :: CInt -> IO () -- | Log output is sent to stderr. @@ -37,4 +33,4 @@ setLogLevel (LogLevel l) = av_log_set_level l -- initially set to @quiet@. If you would like the standard ffmpeg -- debug level, call @setLogLevel avLogInfo@ after @initFFmpeg@. initFFmpeg :: IO () -initFFmpeg = av_register_all >> avdevice_register_all >> setLogLevel avLogQuiet +initFFmpeg = avdevice_register_all >> setLogLevel avLogQuiet diff --git a/src/Codec/FFmpeg/AudioStream.hs b/src/Codec/FFmpeg/AudioStream.hs index 447d704..4ecca0e 100644 --- a/src/Codec/FFmpeg/AudioStream.hs +++ b/src/Codec/FFmpeg/AudioStream.hs @@ -2,14 +2,14 @@ module Codec.FFmpeg.AudioStream where import Codec.FFmpeg.Enums import Data.Bits -import qualified Data.Vector.Storable as V import Foreign.C.Types +import Codec.FFmpeg.Types (AVChannelLayout) data AudioStream = AudioStream { asBitRate :: CInt , asSampleFormat :: AVSampleFormat , asSampleRate :: CInt - , asChannelLayout :: CULong + , asChannelLayout :: AVChannelLayout , asChannelCount :: CInt , asCodec :: AVCodecID } diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc index 81c65f5..16c9801 100644 --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -15,6 +15,10 @@ import Foreign.Marshal.Array (advancePtr, mallocArray) import Foreign.Ptr import Foreign.Storable +-- | libavdevice still requries registration +foreign import ccall "avdevice_register_all" + avdevice_register_all :: IO () + foreign import ccall "avcodec_open2" open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt @@ -36,7 +40,7 @@ foreign import ccall "av_init_packet" foreign import ccall "av_packet_alloc" av_packet_alloc :: IO AVPacket -foreign import ccall "av_free_packet" +foreign import ccall "av_packet_unref" free_packet :: AVPacket -> IO () foreign import ccall "av_malloc" @@ -57,9 +61,6 @@ foreign import ccall "sws_scale" -> 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 @@ -78,6 +79,12 @@ foreign import ccall "av_opt_set_sample_fmt" foreign import ccall "av_opt_get_sample_fmt" av_opt_get_sample_fmt :: Ptr () -> CString -> CInt -> Ptr AVSampleFormat -> IO CInt +foreign import ccall "av_opt_get_chlayout" + av_opt_get_chlayout :: Ptr () -> CString -> CInt -> Ptr AVChannelLayout -> IO CInt + +foreign import ccall "av_opt_set_chlayout" + av_opt_set_chlayout :: Ptr () -> CString -> AVChannelLayout -> CInt -> IO CInt + foreign import ccall "avcodec_send_frame" avcodec_send_frame :: AVCodecContext -> AVFrame -> IO CInt @@ -148,15 +155,17 @@ 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 + when (r < 0) (getError msg r) return r +getError msg r = 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 + avError :: String -> IO a avError msg = throwIO $ FFmpegException $ msg @@ -341,3 +350,6 @@ listSupportedSampleRates codec = do v <- peek ptr return $ v == 0 ) + +first3 :: (t -> a) -> (t, b, c) -> (a, b, c) +first3 f (a,b,c) = (f a,b,c) \ No newline at end of file diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index 77b5f92..82a8ee9 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | 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. @@ -11,8 +12,6 @@ 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.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Maybe @@ -23,6 +22,7 @@ import Foreign.Marshal.Array (advancePtr) import Foreign.Marshal.Utils (with) import Foreign.Ptr import Foreign.Storable +import Codec.FFmpeg.Enums (c_AVERROR_EAGAIN) -- * FFI Declarations @@ -43,8 +43,8 @@ foreign import ccall "avcodec_find_decoder" foreign import ccall "avcodec_find_decoder_by_name" avcodec_find_decoder_by_name :: CString -> IO AVCodec -foreign import ccall "avpicture_get_size" - avpicture_get_size :: AVPixelFormat -> CInt -> CInt -> IO CInt +foreign import ccall "av_image_get_buffer_size" + av_image_get_buffer_size :: AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt foreign import ccall "av_malloc" av_malloc :: CSize -> IO (Ptr ()) @@ -52,13 +52,9 @@ foreign import ccall "av_malloc" 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 +foreign import ccall "avcodec_send_frame" + decode_video :: AVCodecContext -> AVFrame -> IO CInt + foreign import ccall "avformat_close_input" close_input :: Ptr AVFormatContext -> IO () @@ -68,9 +64,6 @@ foreign import ccall "av_dict_set" foreign import ccall "av_find_input_format" av_find_input_format :: CString -> IO (Ptr AVInputFormat) -foreign import ccall "av_format_set_video_codec" - av_format_set_video_codec :: AVFormatContext -> AVCodec -> IO () - dictSet :: Ptr AVDictionary -> String -> String -> IO () dictSet d k v = do r <- withCString k $ \k' -> withCString v $ \v' -> @@ -113,11 +106,11 @@ openCamera cam cfg = setupCamera :: AVFormatContext -> String -> IO () setupCamera avfc c = do setCamera avfc - setFilename avfc c + setUrl avfc c when (format cfg == Just "mjpeg") $ do mjpeg <- avcodec_find_decoder avCodecIdMjpeg setVideoCodecID avfc avCodecIdMjpeg - av_format_set_video_codec avfc mjpeg + setVideoCodec avfc mjpeg openInput :: (MonadIO m, MonadError String m) => InputSource -> m AVFormatContext openInput ipt = @@ -136,11 +129,6 @@ openFile filename = fail $ "ffmpeg failed opening file: " ++ s) peek ctx --- | @AVFrame@ is a superset of @AVPicture@, so we can upcast an --- 'AVFrame' to an 'AVPicture'. -frameAsPicture :: AVFrame -> AVPicture -frameAsPicture = AVPicture . getPtr - -- | Find a codec given by name. findDecoder :: (MonadIO m, MonadError String m) => String -> m AVCodec findDecoder name = @@ -170,7 +158,7 @@ findVideoStream fmt = do cod <- peek codec streams <- getStreams fmt vidStream <- peek (advancePtr streams (fromIntegral i)) - ctx <- getCodecContext vidStream + ctx <- createCodecContext cod vidStream return (i, ctx, cod, vidStream) findAudioStream :: (MonadIO m, MonadError String m) @@ -184,9 +172,17 @@ findAudioStream fmt = do cod <- peek codec streams <- getStreams fmt audioStream <- peek (advancePtr streams (fromIntegral i)) - ctx <- getCodecContext audioStream + ctx <- createCodecContext cod audioStream return (i, ctx, cod, audioStream) +createCodecContext :: HasCodecParams t => AVCodec -> t -> IO AVCodecContext +createCodecContext cod stream = do + pCodecCtx <- avcodec_alloc_context3 cod; + codecPar <- getCodecParams stream + res <- avcodec_parameters_to_context pCodecCtx codecPar + when (res < 0) (fail "Couldn't get codec parameters for video stream") + pure pCodecCtx + -- | Find a registered decoder with a codec ID matching that found in -- the given 'AVCodecContext'. getDecoder :: (MonadIO m, MonadError String m) @@ -207,37 +203,43 @@ openCodec ctx cod = peek dict -- | Return the next frame of a stream. -read_frame_check :: AVFormatContext -> AVPacket -> IO () -read_frame_check ctx pkt = do r <- av_read_frame ctx pkt - when (r < 0) (fail "Frame read failed") +readFrameCheck :: AVFormatContext -> AVPacket -> IO () +readFrameCheck ctx pkt = do + r <- av_read_frame ctx pkt + when (r < 0) (fail "Frame read failed") -- | Read frames of the given 'AVPixelFormat' from a video stream. +-- | Also read side data or metadata of stream and return this if present frameReader :: (MonadIO m, MonadError String m) - => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ()) -frameReader dstFmt ipt = - do inputContext <- openInput ipt - checkStreams inputContext - (vidStreamIndex, ctx, cod, _vidStream) <- findVideoStream inputContext - _ <- openCodec ctx cod - prepareReader inputContext vidStreamIndex dstFmt ctx + => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO (), Maybe AVDictionary) +frameReader dstFmt ipt = do + inputContext <- openInput ipt + checkStreams inputContext + (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext + _ <- openCodec ctx cod + metadata <- structMetadata vidStream + (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx + pure (reader, cleanup, metadata) -- | Read RGB frames with the result in the 'MaybeT' transformer. -- -- > frameReaderT = fmap (first MaybeT) . frameReader frameReaderT :: (Functor m, MonadIO m, MonadError String m) - => InputSource -> m (MaybeT IO AVFrame, IO ()) -frameReaderT = fmap (first MaybeT) . frameReader avPixFmtRgb24 + => InputSource -> m (MaybeT IO AVFrame, IO (), Maybe AVDictionary) +frameReaderT = fmap (first3 MaybeT) . frameReader avPixFmtRgb24 + -- | Read time stamped frames of the given 'AVPixelFormat' from a -- video stream. Time is given in seconds from the start of the -- stream. frameReaderTime :: (MonadIO m, MonadError String m) => AVPixelFormat -> InputSource - -> m (IO (Maybe (AVFrame, Double)), IO ()) + -> m (IO (Maybe (AVFrame, Double)), IO (), Maybe AVDictionary) frameReaderTime dstFmt src = do inputContext <- openInput src checkStreams inputContext (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext + metadata <- structMetadata vidStream _ <- openCodec ctx cod (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx AVRational num den <- liftIO $ getTimeBase vidStream @@ -250,21 +252,22 @@ frameReaderTime dstFmt src = Nothing -> return Nothing Just f -> do t <- frameTime' f return $ Just (f, t) - return (readTS, cleanup) + return (readTS, cleanup, metadata) frameAudioReader :: (MonadIO m, MonadError String m) - => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO ()) + => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO (), Maybe AVDictionary) frameAudioReader fileName = do inputContext <- openInput fileName checkStreams inputContext (audioStreamIndex, ctx, cod, audioStream) <- findAudioStream inputContext + metadata <- structMetadata audioStream openCodec ctx cod as <- liftIO $ do bitrate <- getBitRate ctx samplerate <- getSampleRate ctx channelLayout <- getChannelLayout ctx sampleFormat <- getSampleFormat ctx - channels <- getChannels ctx + channels <- getChannels channelLayout codecId <- getCodecID cod return $ AudioStream { asBitRate = bitrate @@ -275,15 +278,15 @@ frameAudioReader fileName = do , asCodec = codecId } (readFrame, finalize) <- prepareAudioReader inputContext audioStreamIndex ctx - return (as, readFrame, finalize) + return (as, readFrame, finalize, metadata) -- | Read time stamped RGB frames with the result in the 'MaybeT' -- transformer. -- -- > frameReaderT = fmap (first MaybeT) . frameReader frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m) - => InputSource -> m (MaybeT IO (AVFrame, Double), IO ()) -frameReaderTimeT = fmap (first MaybeT) . frameReaderTime avPixFmtRgb24 + => InputSource -> m (MaybeT IO (AVFrame, Double), IO (), Maybe AVDictionary) +frameReaderTimeT = fmap (first3 MaybeT) . frameReaderTime avPixFmtRgb24 prepareAudioReader :: (MonadIO m, MonadError String m) => AVFormatContext -> CInt -> AVCodecContext @@ -341,16 +344,19 @@ prepareReader fmtCtx vidStream dstFmt codCtx = _ <- codec_close codCtx with fmtCtx close_input free (getPtr pkt) + -- This function follows the steps from https://ffmpeg.org/doxygen/trunk/group__lavc__encdec.html getFrame = do - read_frame_check fmtCtx pkt + readFrameCheck fmtCtx pkt whichStream <- getStreamIndex pkt if whichStream == vidStream then do - fin <- alloca $ \finished -> do - _ <- decode_video codCtx fRaw finished pkt - peek finished - if fin > 0 - then do + frameReady <- avcodec_send_packet codCtx pkt + if frameReady == c_AVERROR_EAGAIN then do + -- Frame is ready to read + avcodec_receive_frame codCtx fRaw -- TODO: non zero is an error here + -- Send the packet to the decoder + avcodec_send_packet codCtx pkt -- TODO: non zero is an error here + -- Some streaming codecs require a final flush with -- an empty packet -- fin' <- alloca $ \fin2 -> do @@ -360,13 +366,13 @@ prepareReader fmtCtx vidStream dstFmt codCtx = -- decode_video codCtx fRaw fin2 pkt -- peek fin2 - _ <- swsScale sws fRaw fRgb + _ <- swsScale sws fRaw fRgb -- Copy the raw frame's timestamp to the RGB frame - getPktPts fRaw >>= setPts fRgb + getPktDts fRaw >>= setPts fRgb - free_packet pkt - return $ Just fRgb + free_packet pkt + return $ Just fRgb else free_packet pkt >> getFrame else free_packet pkt >> getFrame return (getFrame `catchError` const (return Nothing), cleanup) diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc index 7db9266..bf7d658 100644 --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -16,7 +16,7 @@ import Codec.Picture import Control.Monad (when, void) import Data.Bits import Data.IORef -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Data.Ord (comparing) import Data.Traversable (for) import Data.Vector.Storable (Vector) @@ -50,10 +50,6 @@ foreign import ccall "avcodec_find_encoder_by_name" foreign import ccall "av_opt_set" av_opt_set :: Ptr () -> CString -> CString -> CInt -> IO CInt -foreign import ccall "avcodec_encode_video2" - avcodec_encode_video2 :: AVCodecContext -> AVPacket -> AVFrame -> Ptr CInt - -> IO CInt - foreign import ccall "av_image_alloc" av_image_alloc :: Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt -> AVPixelFormat -> CInt -> IO CInt @@ -144,7 +140,7 @@ data AVEncodingParams = AVEncodingParams -- ^ If 'Nothing', automatically chose a pixel format -- based on the output codec. If 'Just', force the -- selected pixel format. - , avepChannelLayout :: CULong + , avepChannelLayout :: AVChannelLayout -- ^ Channel layout for the audio stream , avepSampleRate :: CInt -- ^ Sample rate for the audio stream @@ -166,7 +162,7 @@ data AVEncodingParams = AVEncodingParams -- | Minimal parameters describing the desired audio/video output. data AEncodingParams = AEncodingParams - { aepChannelLayout :: CULong + { aepChannelLayout :: AVChannelLayout -- ^ Channel layout for the audio stream , aepSampleRate :: CInt -- ^ Sample rate for the audio stream @@ -290,7 +286,8 @@ initVideoStream vp oc = do let framePeriod = AVRational 1 (fromIntegral $ vpFps vp) frameRate = AVRational (fromIntegral $ vpFps vp) 1 setTimeBase st framePeriod - ctx <- getCodecContext st + ctx <- avcodec_alloc_context3 cod + when (getPtr ctx == nullPtr) (error "Failed to allocate codec context") setWidth ctx (vpWidth vp) setHeight ctx (vpHeight vp) setTimeBase ctx framePeriod @@ -305,6 +302,7 @@ initVideoStream vp oc = do -- Some formats want stream headers to be separate needsHeader <- checkFlag avfmtGlobalheader <$> (getOutputFormat oc >>= getFormatFlags) + when needsHeader $ #if LIBAVFORMAT_VERSION_MAJOR < 57 getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader) @@ -324,6 +322,9 @@ initVideoStream vp oc = do rOpen <- open_codec ctx cod nullPtr when (rOpen < 0) (error "Couldn't open codec") + codecParams <- getCodecParams st + runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) + return (st, ctx) initAudioStream :: AudioParams @@ -331,7 +332,6 @@ initAudioStream :: AudioParams -> 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") @@ -355,6 +355,12 @@ initAudioStream params oc = do codecParams <- getCodecParams st runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) +#if LIBAVFORMAT_VERSION_MAJOR < 57 + getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader) +#else + getCodecFlags ctx >>= setCodecFlags ctx . (.|. avCodecFlagGlobalHeader) +#endif + return (st, cod, ctx) @@ -412,10 +418,16 @@ avio_close_check oc = do r <- getIOContext oc >>= avio_close -- data; 'False' otherwise. encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool encode_video_check ctx pkt frame = - alloca $ \gotOutput -> do - r <- avcodec_encode_video2 ctx pkt frame' gotOutput - when (r < 0) (error "Error encoding frame") - (> 0) <$> peek gotOutput + do + --r <- avcodec_encode_video2 ctx pkt frame' gotOutput + r <- avcodec_send_frame ctx frame' + if (r == 0 || r == c_AVERROR_EAGAIN) then do + e <- avcodec_receive_packet ctx pkt + pure (e /= c_AVERROR_EAGAIN) + else if r == c_AVERROR_EOF then + pure False + else + getError "Error encoding frame" r where frame' = fromMaybe (AVFrame nullPtr) frame -- | Allocate the stream private data and write the stream header to @@ -555,10 +567,12 @@ avWriter outputFormat sp fname = do (Just <$> initVideoStream vp oc) mAudioStream <- withAudioParams sp (return Nothing) $ \ap -> (Just <$> initAudioStream ap oc) + avio_open_check oc fname numStreams <- getNumStreams oc + withCString fname (\str -> av_dump_format oc 0 str 1) write_header_check oc - + alreadyClosedRef <- newIORef False let writeClose = do alreadyClosed <- readIORef alreadyClosedRef diff --git a/src/Codec/FFmpeg/Enums.hsc b/src/Codec/FFmpeg/Enums.hsc index 136fc84..5e29e4f 100644 --- a/src/Codec/FFmpeg/Enums.hsc +++ b/src/Codec/FFmpeg/Enums.hsc @@ -530,3 +530,43 @@ newtype AVSampleFormat = AVSampleFormat CInt deriving (Eq, Bits, Storable) getSampleFormatInt :: AVSampleFormat -> CInt getSampleFormatInt (AVSampleFormat i) = i + +newtype AVChannelOrder = AVChannelOrder CInt deriving (Eq, Bits, Storable) +#enum AVChannelOrder, AVChannelOrder \ + , AV_CHANNEL_ORDER_UNSPEC\ + , AV_CHANNEL_ORDER_NATIVE\ + , AV_CHANNEL_ORDER_CUSTOM\ + , AV_CHANNEL_ORDER_AMBISONIC + +getChannelOrderInt :: AVChannelOrder -> CInt +getChannelOrderInt (AVChannelOrder i) = i + +av_dict_match_case :: CInt +av_dict_match_case = 1 -- Only get an entry with exact-case key match. Only relevant in av_dict_get(). + +av_dict_ignore_suffix :: CInt +av_dict_ignore_suffix = 2 -- Return first entry in a dictionary whose first part corresponds to the search key, + -- ignoring the suffix of the found key string. Only relevant in av_dict_get(). + +av_dict_dont_strdup_key :: CInt +av_dict_dont_strdup_key = 4 -- Take ownership of a key that's been + -- allocated with av_malloc() or another memory allocation function. +av_dict_dont_strdup_val :: CInt +av_dict_dont_strdup_val = 8 -- Take ownership of a value that's been + -- allocated with av_malloc() or another memory allocation function. + +av_dict_dont_overwrite :: CInt +av_dict_dont_overwrite = 16 -- Don't overwrite existing entries. + +av_dict_append :: CInt +av_dict_append = 32 -- If the entry already exists, append to it. Note that no + -- delimiter is added, the strings are simply concatenated. + +av_dict_multikey :: CInt +av_dict_multikey = 64 -- Allow to store several equal keys in the dictionary + +c_AVERROR_EAGAIN :: CInt +c_AVERROR_EAGAIN = #const AVERROR(EAGAIN) + +c_AVERROR_EOF :: CInt +c_AVERROR_EOF = #const AVERROR_EOF \ No newline at end of file diff --git a/src/Codec/FFmpeg/Internal/Debug.hsc b/src/Codec/FFmpeg/Internal/Debug.hsc index e6b4303..b79591a 100644 --- a/src/Codec/FFmpeg/Internal/Debug.hsc +++ b/src/Codec/FFmpeg/Internal/Debug.hsc @@ -36,7 +36,6 @@ debugCodecContext (AVCodecContext p) = do (#peek AVCodecContext, gop_size) p >>= si "gop_size" (#peek AVCodecContext, bit_rate) p >>= si "bit_rate" (#peek AVCodecContext, max_b_frames) p >>= si "max_b_frames" - (#peek AVCodecContext, b_frame_strategy) p >>= si "b_frame_strategy" (#peek AVCodecContext, qmin) p >>= si "qmin" (#peek AVCodecContext, qmax) p >>= si "qmax" (#peek AVCodecContext, me_cmp) p >>= si "me_cmp" diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index 07830f9..84ecda4 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -6,10 +6,9 @@ import Codec.FFmpeg.Common import Codec.FFmpeg.Decode import Codec.FFmpeg.Encode import Codec.FFmpeg.Enums +import Codec.FFmpeg.Probe import Codec.FFmpeg.Internal.Linear (V2(..)) import Codec.FFmpeg.Types -import Control.Arrow (first) -import Control.Monad ((>=>), guard) import Control.Monad.Except import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -19,7 +18,7 @@ import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.Types import Foreign.Storable (sizeOf) -import Data.Maybe (maybe) +import Data.List.NonEmpty (NonEmpty, singleton, (<|)) -- | Convert 'AVFrame' to a 'Vector'. @@ -114,29 +113,54 @@ juicyPixelStride :: forall a proxy. Pixel a => proxy a -> Int juicyPixelStride _ = sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a) +type Metadata = NonEmpty (String, String) + +-- avDictionaryToMetadata :: MonadIO m => AVDictionary -> m (Maybe Metadata) +-- avDictionaryToMetadata avdict = liftIO $ do +-- nullStr <- newCString "" +-- nonEmpty <$> checkKeyVal nullStr (AVDictionaryEntry nullPtr) [] +-- where +-- checkKeyVal nullStr prevEntry lst = do +-- avde@(AVDictionaryEntry ptrres) <- av_dict_get avdict nullStr prevEntry av_dict_ignore_suffix +-- if nullPtr == ptrres then pure lst else do +-- key <- peekCString =<< getKey avde +-- val <- peekCString =<< getValue avde +-- checkKeyVal nullPtr prevEntry ((key, val) : lst) + +mapToResult :: (MonadIO m, JuicyPixelFormat p) => m (a1, b, Maybe AVDictionary) -> ((AVFrame -> IO (Maybe (Image p))) -> a1 -> MaybeT m2 a2) -> m (m2 (Maybe a2), b, Maybe Metadata) +mapToResult f aux = do + (frame, cleanup, avdict) <- f + let frameResult = runMaybeT (aux toJuicyImage frame) + metadata <- dictFoldM folder Nothing `mapM` avdict + pure (frameResult, cleanup, join metadata) + where + folder Nothing kv = pure (Just (singleton kv)) + folder (Just nes) kv = pure (Just (kv <| nes)) + -- | Read frames from a video stream. imageReaderT :: forall m p. (Functor m, MonadIO m, MonadError String m, JuicyPixelFormat p) - => InputSource -> m (IO (Maybe (Image p)), IO ()) -imageReaderT = fmap (first (runMaybeT . aux toJuicyImage)) - . frameReader (juicyPixelFormat ([] :: [p])) + => InputSource -> m (IO (Maybe (Image p)), IO (), Maybe Metadata) +imageReaderT is = mapToResult (frameReader (juicyPixelFormat ([] :: [p])) is) aux + + --fmap (first3 (runMaybeT . aux toJuicyImage)) +-- . frameReader (juicyPixelFormat ([] :: [p])) where aux g x = MaybeT x >>= MaybeT . g -- | Read frames from a video stream. Errors are thrown as -- 'IOException's. imageReader :: JuicyPixelFormat p - => InputSource -> IO (IO (Maybe (Image p)), IO ()) -imageReader = (>>= either error return) . runExceptT . imageReaderT + => InputSource -> IO (IO (Maybe (Image p)), IO (), Maybe Metadata) +imageReader = either error return <=< (runExceptT . imageReaderT) -- | Read time stamped frames from a video stream. Time is given in -- seconds from the start of the stream. imageReaderTimeT :: forall m p. (Functor m, MonadIO m, MonadError String m, JuicyPixelFormat p) - => InputSource -> m (IO (Maybe (Image p, Double)), IO ()) -imageReaderTimeT = fmap (first (runMaybeT . aux toJuicyImage)) - . frameReaderTime (juicyPixelFormat ([] :: [p])) + => InputSource -> m (IO (Maybe (Image p, Double)), IO (), Maybe Metadata) +imageReaderTimeT is = mapToResult (frameReaderTime (juicyPixelFormat ([] :: [p])) is) aux where aux g x = do (f,t) <- MaybeT x f' <- MaybeT $ g f return (f', t) @@ -145,8 +169,8 @@ imageReaderTimeT = fmap (first (runMaybeT . aux toJuicyImage)) -- seconds from the start of the stream. Errors are thrown as -- 'IOException's. imageReaderTime :: JuicyPixelFormat p - => InputSource -> IO (IO (Maybe (Image p, Double)), IO ()) -imageReaderTime = (>>= either error return) . runExceptT . imageReaderTimeT + => InputSource -> IO (IO (Maybe (Image p, Double)), IO (), Maybe Metadata) +imageReaderTime = either error return <=< runExceptT . imageReaderTimeT -- | Open a target file for writing a video stream. When the returned -- function is applied to 'Nothing', the output stream is closed. Note @@ -161,8 +185,8 @@ imageReaderTime = (>>= either error return) . runExceptT . imageReaderTimeT imageWriter :: forall p. JuicyPixelFormat p => EncodingParams -> FilePath -> IO (Maybe (Image p) -> IO ()) imageWriter ep f = do - videoWriter <- frameWriter ep f - return $ (. fmap fromJuciy) videoWriter + vw <- videoWriter ep f + return $ (. fmap fromJuciy) vw -- | Util function to convert a JuicyPixels image to the same structure -- used by 'frameWriter' diff --git a/src/Codec/FFmpeg/Probe.hsc b/src/Codec/FFmpeg/Probe.hsc index 8f815be..ccd77e9 100644 --- a/src/Codec/FFmpeg/Probe.hsc +++ b/src/Codec/FFmpeg/Probe.hsc @@ -8,12 +8,12 @@ module Codec.FFmpeg.Probe ( withAvFile, nbStreams, formatName, formatMetadata, duration, -- * Streams - AvStreamT, withStream, codecContext, codecName, + AvStreamT, withStream, codecName, codecMediaTypeName, streamBitrate, streamMetadata, codec, streamImageSize, -- * Dictionaries - dictFoldM_ + dictFoldM_, dictFoldM ) where import Control.Applicative ( Applicative ) @@ -23,6 +23,7 @@ import Control.Monad.IO.Class ( MonadIO ) import Control.Monad.Reader import Control.Monad.Trans.Except import Data.Int ( Int64 ) +import Data.Maybe (fromMaybe) import Foreign.C.String ( CString, peekCString, withCString ) import Foreign.C.Types ( CInt(..) ) import Foreign.Marshal.Utils ( with ) @@ -34,6 +35,7 @@ import Codec.FFmpeg.Decode import Codec.FFmpeg.Types #include +#include ------------------------------------------------------------------------------- -- avformat - level stuff @@ -96,12 +98,12 @@ withStream sid f = nbStreams >>= \ns -> if sid >= ns streams <- liftIO $ (#peek AVFormatContext, streams) (getPtr ctx) liftIO (peekElemOff streams sid) >>= runReaderT (unAvStreamT f) -codecContext :: MonadIO m => AvStreamT m (Maybe AVCodecContext) -codecContext = do - p <- ask >>= (liftIO . (#peek AVStream, codec) . getPtr) - if (p /= nullPtr) - then return $ Just $ AVCodecContext p - else return Nothing +-- codecContext :: MonadIO m => AvStreamT m (Maybe AVCodecContext) +-- codecContext = do +-- p <- ask >>= (liftIO . (#peek AVStream, codec) . getPtr) +-- if (p /= nullPtr) +-- then return $ Just $ AVCodecContext p +-- else return Nothing codecMediaTypeName :: MonadIO m => AVCodecContext -> AvStreamT m String codecMediaTypeName cctx = liftIO $ @@ -144,18 +146,47 @@ dictFoldM_ f d = let flags = (#const AV_DICT_IGNORE_SUFFIX + AV_DICT_DONT_STRDUP_KEY + AV_DICT_DONT_STRDUP_VAL) next ep = do - e' <- liftIO $ withCString "" $ \s -> av_dict_get d s ep flags + ave@(AVDictionaryEntry e') <- liftIO $ withCString "" $ \s -> av_dict_get d s ep flags if (e' == nullPtr) then return () else do k <- liftIO $ (#peek AVDictionaryEntry, key) e' >>= peekCString v <- liftIO $ (#peek AVDictionaryEntry, value) e' >>= peekCString f (k, v) - next e' + next ave in do -- e <- liftIO $ malloc >>= \m -> poke m nullPtr >> return m - next nullPtr + next (AVDictionaryEntry nullPtr) +dictFoldM + :: MonadIO m + => (b -> (String, String) -> m b) + -> b + -> AVDictionary + -> m b +dictFoldM f b d = + let + flags = (#const AV_DICT_IGNORE_SUFFIX + AV_DICT_DONT_STRDUP_KEY + AV_DICT_DONT_STRDUP_VAL) + next ep = do + ave@(AVDictionaryEntry e') <- liftIO $ withCString "" $ \s -> av_dict_get d s ep flags + if (e' == nullPtr) + then return b + else do + k <- liftIO $ (#peek AVDictionaryEntry, key) e' >>= peekCString + v <- liftIO $ (#peek AVDictionaryEntry, value) e' >>= peekCString + f b (k, v) + next ave + in do + -- e <- liftIO $ malloc >>= \m -> poke m nullPtr >> return m + next (AVDictionaryEntry nullPtr) + +getDictionaryEntry :: AVDictionary -> String -> Maybe AVDictionaryEntry -> Int -> IO (Maybe AVDictionaryEntry) +getDictionaryEntry avdict key prevEntry flags = do + let prevPtr = fromMaybe (AVDictionaryEntry nullPtr) prevEntry + withCString key $ \keyCString -> do + avde@(AVDictionaryEntry entryPtr) <- av_dict_get avdict keyCString prevPtr (fromIntegral flags) + pure (if entryPtr == nullPtr then Nothing else (Just avde)) + ------------------------------------------------------------------------------- -- helpers ------------------------------------------------------------------------------- @@ -174,4 +205,9 @@ foreign import ccall "avcodec_get_name" avcodec_get_name :: AVCodecID -> IO CString foreign import ccall "av_dict_get" - av_dict_get :: AVDictionary -> CString -> Ptr () -> CInt -> IO (Ptr ()) + av_dict_get :: AVDictionary + -> CString + -> AVDictionaryEntry + -> CInt + -> IO AVDictionaryEntry + diff --git a/src/Codec/FFmpeg/Resampler.hs b/src/Codec/FFmpeg/Resampler.hs index fb32e12..55caca8 100644 --- a/src/Codec/FFmpeg/Resampler.hs +++ b/src/Codec/FFmpeg/Resampler.hs @@ -23,7 +23,7 @@ foreign import ccall "swr_get_out_samples" swr_get_out_samples :: SwrContext -> CInt -> IO CInt data AudioParams = AudioParams - { apChannelLayout :: CULong + { apChannelLayout :: AVChannelLayout , apSampleRate :: CInt , apSampleFormat :: AVSampleFormat } @@ -51,8 +51,7 @@ makeResampler ctx inParams outParams = do srcData = castPtr (hasData frame) dstDataPtr <- malloc lineSize <- malloc - dstChannelCount <- av_get_channel_layout_nb_channels - (apChannelLayout outParams) + dstChannelCount <- getChannels (apChannelLayout outParams) _ <- runWithError "Could not alloc samples" (av_samples_alloc_array_and_samples dstDataPtr lineSize dstChannelCount (fromIntegral dstSamples) @@ -114,19 +113,15 @@ initSwrContext inParams outParams = 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_sample_fmt str fmt = withCString str $ \cStr -> av_opt_set_sample_fmt (getPtr swr) cStr fmt 0 + set_channel_layout str avchl = withCString str $ \cStr -> av_opt_set_chlayout (getPtr swr) cStr avchl 0 - -- set_int "in_channel_count" (aoChannelCount inParams) - set_int "in_channel_layout" (apChannelLayout inParams) + void $ set_channel_layout "in_ch_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) + void $ set_sample_fmt "in_sample_fmt" (apSampleFormat inParams) + void $ set_channel_layout "out_ch_layout" (apChannelLayout outParams) set_int "out_sample_rate" (apSampleRate outParams) - set_sample_fmt "out_sample_fmt" (apSampleFormat outParams) + void $ set_sample_fmt "out_sample_fmt" (apSampleFormat outParams) void $ runWithError "Failed to initialize the resampling context" (swr_init swr) diff --git a/src/Codec/FFmpeg/Types.hsc b/src/Codec/FFmpeg/Types.hsc index 32725aa..3c58ea6 100644 --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -9,6 +9,7 @@ import Foreign.C.Types import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Alloc (malloc) +import Control.Monad.IO.Class (liftIO, MonadIO) #include #include @@ -30,6 +31,8 @@ newtype AVFormatContext = AVFormatContext (Ptr ()) deriving (Storable, HasPtr) #mkField OutputFormat, AVOutputFormat #mkField IOContext, AVIOContext #mkField InputFormat, AVInputFormat +#mkField VideoCodec, AVCodec +#mkField AudioCodec, AVCodec #hasField AVFormatContext, NumStreams, nb_streams #hasField AVFormatContext, Streams, streams @@ -37,11 +40,18 @@ newtype AVFormatContext = AVFormatContext (Ptr ()) deriving (Storable, HasPtr) #hasField AVFormatContext, InputFormat, iformat #hasField AVFormatContext, IOContext, pb #hasField AVFormatContext, VideoCodecID, video_codec_id +#hasField AVFormatContext, VideoCodec, video_codec +#hasField AVFormatContext, AudioCodec, audio_codec -setFilename :: AVFormatContext -> String -> IO () -setFilename ctx fn = +structMetadata :: (MonadIO m, HasPtr a) => a -> m (Maybe AVDictionary) +structMetadata ctx = do + dict@(AVDictionary dictPtr) <- liftIO $ (#peek AVFormatContext, metadata) (getPtr ctx) + pure $ if dictPtr == nullPtr then Nothing else (Just dict) + +setUrl :: AVFormatContext -> String -> IO () +setUrl ctx fn = do let ptr = getPtr ctx - dst = (#ptr AVFormatContext, filename) ptr + dst = (#ptr AVFormatContext, url) ptr bytes = map (fromIntegral . fromEnum) fn zipWithM_ (pokeElemOff dst) bytes [(0 :: CInt) ..] @@ -69,6 +79,14 @@ foreign import ccall "avformat_alloc_context" mallocAVFormatContext :: IO AVFormatContext mallocAVFormatContext = AVFormatContext <$> avformat_alloc_context +newtype AVChannelLayout = AVChannelLayout (Ptr ()) deriving (Storable, HasPtr) + +#mkField ChannelOrder, AVChannelOrder +#mkField Channels, CInt + +#hasField AVChannelLayout, ChannelOrder, order +#hasField AVChannelLayout, Channels, nb_channels + newtype AVCodecContext = AVCodecContext (Ptr ()) deriving (Storable, HasPtr) foreign import ccall "avcodec_alloc_context3" @@ -88,12 +106,13 @@ foreign import ccall "avcodec_alloc_context3" #mkField TicksPerFrame, CInt #mkField RawAspectRatio, AVRational #mkField SampleRate, CInt -#mkField ChannelLayout, CULong -#mkField Channels, CInt +#mkField ChannelLayout, AVChannelLayout #mkField FrameSize, CInt #mkField FrameRate, AVRational +#mkField Codec, AVCodec #hasField AVCodecContext, BitRate, bit_rate +#hasField AVCodecContext, Codec, codec #hasField AVCodecContext, Width, width #hasField AVCodecContext, Height, height #hasField AVCodecContext, TimeBase, time_base @@ -106,7 +125,6 @@ foreign import ccall "avcodec_alloc_context3" #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 @@ -135,17 +153,25 @@ foreign import ccall "avcodec_parameters_from_context" -> AVCodecContext -> IO CInt +foreign import ccall "avcodec_parameters_to_context" + avcodec_parameters_to_context :: AVCodecContext + -> AVCodecParameters + -> IO CInt + newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) #mkField Id, CInt #mkField CodecContext, AVCodecContext #mkField StreamIndex, CInt #mkField CodecParams, AVCodecParameters +#mkField Dictionary, AVDictionary + +-- Update this to include side data & metadata in the structure #hasField AVStream, Id, id #hasField AVStream, TimeBase, time_base -#hasField AVStream, CodecContext, codec #hasField AVStream, StreamIndex, index #hasField AVStream, CodecParams, codecpar +#hasField AVStream, Dictionary, metadata newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) #mkField LongName, CString @@ -165,10 +191,20 @@ newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) #hasField AVCodec, SupportedSampleRates, supported_samplerates #hasField AVCodec, Capabilities, capabilities +newtype AVDictionaryEntry = AVDictionaryEntry (Ptr ()) deriving (Storable, HasPtr) +#mkField Key, CString +#mkField Value, CString + +#hasField AVDictionaryEntry, Key, key +#hasField AVDictionaryEntry, Value, value + + +-- Use av_dict_get and av_dict_set to actually access this structure newtype AVDictionary = AVDictionary (Ptr ()) deriving (Storable, HasPtr) + newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr) #mkField Pts, CLong -#mkField PktPts, CLong +#mkField PktDts, CLong #mkField LineSize, CInt #mkField Data, (Ptr (Ptr ())) #mkField ExtendedData, (Ptr (Ptr ())) @@ -181,18 +217,14 @@ newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr) #hasField AVFrame, Height, height #hasField AVFrame, LineSize, linesize #hasField AVFrame, Pts, pts -#hasField AVFrame, PktPts, pkt_pts +#hasField AVFrame, PktDts, pkt_dts #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, ChannelLayout, ch_layout #hasField AVFrame, SampleRate, sample_rate -newtype AVPicture = AVPicture (Ptr ()) deriving (Storable, HasPtr) -#hasField AVPicture, Data, data - newtype SwsContext = SwsContext (Ptr ()) deriving (Storable, HasPtr) newtype AVOutputFormat = AVOutputFormat (Ptr ()) deriving (Storable, HasPtr) #mkField FormatFlags, FormatFlag @@ -246,9 +278,6 @@ newtype AVPacket = AVPacket (Ptr ()) deriving (Storable, HasPtr) packetSize :: Int packetSize = #size AVPacket -pictureSize :: Int -pictureSize = #size AVPicture - newtype SwrContext = SwrContext (Ptr ()) deriving (Storable, HasPtr) newtype AVAudioFifo = AVAudioFifo (Ptr ()) deriving (Storable, HasPtr) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 0e4cb13..0000000 --- a/stack.yaml +++ /dev/null @@ -1,41 +0,0 @@ -resolver: lts-9.21 - -packages: -- '.' - -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: -- Rasterific-0.6.1.1 -- FontyFruity-0.5.3.2 -- sdl2-2.1.3.1 - -# Override default flag values for local packages and extra-deps -flags: - ffmpeg-light: - BuildDemo: true - BuildRasterDemo: true - BuildVPlayDemo: true - BuildTranscodeDemo: true - BuildAudioExtractDemo: true - BuildAudioSinDemo: true - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -nix: - enable: false - packages: [ ffmpeg-full, pkgconfig, zlib, SDL2 ] - pure: false - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] - -# nix-store -r $(nix-instantiate '' -A ffmpeg-full) -# extra-include-dirs: [/nix/store/nq5n4053yhkxwwlirjm4k8zh1r1hzc16-ffmpeg-full-3.0/include] -# extra-lib-dirs: [/nix/store/nq5n4053yhkxwwlirjm4k8zh1r1hzc16-ffmpeg-full-3.0/lib] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock index a0aa7cc..eeb4ab3 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -7,27 +7,27 @@ packages: - completed: hackage: Rasterific-0.6.1.1@sha256:02890bd3903e37aebfe8c89909ea108a9fc253053f5368ce0e3ff4544fbaa7d6,5324 pantry-tree: - size: 6278 sha256: bb38f7aafda4c993e43e8aca3feca1083e5a8c2cec4be3756206b87251a040c7 + size: 6278 original: hackage: Rasterific-0.6.1.1 - completed: hackage: FontyFruity-0.5.3.2@sha256:cd43670271c4b96d7a44d199ba52ed087281db52427332077bad187ad89d8bd9,2112 pantry-tree: - size: 1312 sha256: 686e11a72cf6e6276744d11e838ae880e52f4fbf29dc1c909901312e808d5db5 + size: 1312 original: hackage: FontyFruity-0.5.3.2 - completed: hackage: sdl2-2.1.3.1@sha256:13f4bbee291193e48d33888ee6fba3696fe04b464157fca3a9e7fc443bba4dc1,9466 pantry-tree: - size: 6182 sha256: b6090e850aa6f1f63fe1af36b79d1cd01507be3bf19fe17e251f78656eb2267b + size: 6182 original: hackage: sdl2-2.1.3.1 snapshots: - completed: - size: 537868 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/21.yaml - sha256: 0a3be91c2bce851de4755003cfb1d85d62b6f90276231fcc305729c0c5c864a9 - original: lts-9.21 + sha256: e019cd29e3f7f9dbad500225829a3f7a50f73c674614f2f452e21bb8bf5d99ea + size: 650253 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/24.yaml + original: lts-20.24 From f6a436edf34fa58f463f7ad0016d2186792483f3 Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Mon, 25 Mar 2024 15:16:47 +1100 Subject: [PATCH 2/9] Add new AVChannelLayout support --- demo/AudioExtract.hs | 6 +- demo/AudioSin.hs | 128 ++++++++++----------- demo/Transcode.hs | 2 +- demo/VPlay.hs | 6 +- ffmpeg-light.cabal | 1 + src/Codec/FFmpeg/Common.hsc | 17 ++- src/Codec/FFmpeg/Decode.hs | 51 +++++++-- src/Codec/FFmpeg/Display.hsc | 56 ++++++++++ src/Codec/FFmpeg/Encode.hsc | 16 ++- src/Codec/FFmpeg/Enums.hsc | 202 +++++++++++++++++++++++++++++++++- src/Codec/FFmpeg/Juicy.hs | 149 +++++++++++++------------ src/Codec/FFmpeg/Resampler.hs | 7 +- src/Codec/FFmpeg/Types.hsc | 136 +++++++++++++++++++++-- 13 files changed, 599 insertions(+), 178 deletions(-) create mode 100644 src/Codec/FFmpeg/Display.hsc diff --git a/demo/AudioExtract.hs b/demo/AudioExtract.hs index 3d94aa1..c74927e 100644 --- a/demo/AudioExtract.hs +++ b/demo/AudioExtract.hs @@ -18,12 +18,14 @@ main = do initFFmpeg eRes <- runExceptT $ frameAudioReader (File fname) case eRes of Left er -> error er - Right (as, getFrame, cleanup) -> do + 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) + let chLayout = asChannelLayout as + putStrLn $ "channel layout order: " ++ show (order chLayout) + putStrLn $ "channel layout channels: " ++ show (numChannels chLayout) putStrLn $ "channel count : " ++ show (asChannelCount as) let inParams = AudioParams { apChannelLayout = asChannelLayout as diff --git a/demo/AudioSin.hs b/demo/AudioSin.hs index e6b7378..7d7f317 100644 --- a/demo/AudioSin.hs +++ b/demo/AudioSin.hs @@ -13,6 +13,7 @@ import Control.Monad.Except import Data.IORef import Foreign.C.Types import Foreign.Marshal.Array +import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import System.Environment @@ -79,66 +80,67 @@ mkImage w h color = 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 + setLogLevel avLogTrace + + allocaBytes sizeOfAVChannelLayout $ \chanLayout -> do + let w = 1080 + h = 720 + encParams = AVEncodingParams + { avepWidth = w + , avepHeight = h + , avepFps = 30 + , avepCodec = Nothing + , avepPixelFormat = Nothing + , avepChannelLayout = cAV_CHANNEL_LAYOUT_MONO + , avepSampleRate = 44100 + , avepSampleFormat = avSampleFmtFltp + , avepPreset = "" + , avepFormatName = Nothing + , avepDisplayRotation = 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 + putStrLn $ "channel layout order: " ++ show (order ch) + putStrLn $ "channel layout channels: " ++ show (numChannels ch) + + 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/Transcode.hs b/demo/Transcode.hs index ce47657..a690412 100644 --- a/demo/Transcode.hs +++ b/demo/Transcode.hs @@ -34,7 +34,7 @@ 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) + (getFrame, cleanup, _) <- FF.imageReader (FF.File from) putFrame <- FF.imageWriter ep to loop getFrame cleanup putFrame (\x -> return x) diff --git a/demo/VPlay.hs b/demo/VPlay.hs index bb70098..4cbf873 100644 --- a/demo/VPlay.hs +++ b/demo/VPlay.hs @@ -83,7 +83,7 @@ readTSDiff readerTS = do return reader -- Transformer version of updateTextureByFrame. -updateTextureByFrameT :: SDL.Texture -> AVFrame -> MaybeT IO SDL.Texture +updateTextureByFrameT :: SDL.Texture -> AVFrame -> MaybeT IO () updateTextureByFrameT texture frame = copyImageDataT frame >>= updateTexture texture where @@ -92,7 +92,7 @@ updateTextureByFrameT texture frame = SDL.updateTexture t Nothing img -- Update texture by image data from frame. -updateTextureByFrame :: SDL.Texture -> AVFrame -> IO (Maybe SDL.Texture) +updateTextureByFrame :: SDL.Texture -> AVFrame -> IO (Maybe ()) updateTextureByFrame t = runMaybeT . updateTextureByFrameT t -- Return Nothing when condition holds. @@ -300,7 +300,7 @@ videoPlayer cfg src = do let reader' = runMaybeT $ do (f, t) <- MaybeT tsDiffReader updateTextureByFrameT texture f - >>= return . flip (,) t + return (texture, t) -- Texture renderer. render t = do diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal index f207c65..91e3d47 100644 --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -74,6 +74,7 @@ library Codec.FFmpeg.Juicy, Codec.FFmpeg.Probe, Codec.FFmpeg.Resampler, + Codec.FFmpeg.Display, Codec.FFmpeg.Scaler, Codec.FFmpeg.Types, Codec.FFmpeg.Internal.Debug, diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc index 16c9801..ff31bdc 100644 --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -10,7 +10,7 @@ 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.Alloc (allocaBytes, free, alloca) import Foreign.Marshal.Array (advancePtr, mallocArray) import Foreign.Ptr import Foreign.Storable @@ -83,7 +83,7 @@ foreign import ccall "av_opt_get_chlayout" av_opt_get_chlayout :: Ptr () -> CString -> CInt -> Ptr AVChannelLayout -> IO CInt foreign import ccall "av_opt_set_chlayout" - av_opt_set_chlayout :: Ptr () -> CString -> AVChannelLayout -> CInt -> IO CInt + av_opt_set_chlayout :: Ptr () -> CString -> Ptr AVChannelLayout -> CInt -> IO CInt foreign import ccall "avcodec_send_frame" avcodec_send_frame :: AVCodecContext -> AVFrame -> IO CInt @@ -329,15 +329,15 @@ listSupportedSampleFormats codec = do return $ getSampleFormatInt v == -1 ) -listSupportedChannelLayouts :: AVCodec -> IO [CULong] +listSupportedChannelLayouts :: AVCodec -> IO [AVChannelLayout] listSupportedChannelLayouts codec = do chanPtr <- getChannelLayouts codec walkPtrs chanPtr (\ptr -> if ptr == nullPtr then return True else do - v <- peek ptr - return $ v == 0 + co <- peek ptr + return $ (numChannels co) == 0 ) listSupportedSampleRates :: AVCodec -> IO [CInt] @@ -352,4 +352,9 @@ listSupportedSampleRates codec = do ) first3 :: (t -> a) -> (t, b, c) -> (a, b, c) -first3 f (a,b,c) = (f a,b,c) \ No newline at end of file +first3 f (a,b,c) = (f a,b,c) + +set_channel_layout target str avchl = + alloca $ \chlayoutPtr -> do + poke chlayoutPtr avchl + withCString str $ \cStr -> av_opt_set_chlayout (getPtr target) cStr chlayoutPtr 0 \ No newline at end of file diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index 82a8ee9..c641d00 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -12,17 +12,17 @@ import Codec.FFmpeg.Common import Codec.FFmpeg.Enums import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types +import Codec.FFmpeg.Display import Control.Monad.Except import Control.Monad.IO.Class (MonadIO(liftIO)) 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.Array (advancePtr, peekArray) import Foreign.Marshal.Utils (with) import Foreign.Ptr import Foreign.Storable -import Codec.FFmpeg.Enums (c_AVERROR_EAGAIN) -- * FFI Declarations @@ -208,38 +208,47 @@ readFrameCheck ctx pkt = do r <- av_read_frame ctx pkt when (r < 0) (fail "Frame read failed") +data VideoStreamMetadata = VideoStreamMetadata + { metadata :: Maybe AVDictionary + , displayRotation :: Maybe DisplayRotationDegrees + } + +extractVideoStreamMetadata :: MonadIO m => AVStream -> m VideoStreamMetadata +extractVideoStreamMetadata vidStream = do + sd <- getStreamSideData vidStream + VideoStreamMetadata <$> structMetadata vidStream <*> extractDisplayRotation sd + -- | Read frames of the given 'AVPixelFormat' from a video stream. -- | Also read side data or metadata of stream and return this if present frameReader :: (MonadIO m, MonadError String m) - => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO (), Maybe AVDictionary) + => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO (), VideoStreamMetadata ) frameReader dstFmt ipt = do inputContext <- openInput ipt checkStreams inputContext (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext _ <- openCodec ctx cod - metadata <- structMetadata vidStream + metaAndSide <- extractVideoStreamMetadata vidStream (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx - pure (reader, cleanup, metadata) + pure (reader, cleanup, metaAndSide) -- | Read RGB frames with the result in the 'MaybeT' transformer. -- -- > frameReaderT = fmap (first MaybeT) . frameReader frameReaderT :: (Functor m, MonadIO m, MonadError String m) - => InputSource -> m (MaybeT IO AVFrame, IO (), Maybe AVDictionary) + => InputSource -> m (MaybeT IO AVFrame, IO (), VideoStreamMetadata) frameReaderT = fmap (first3 MaybeT) . frameReader avPixFmtRgb24 - -- | Read time stamped frames of the given 'AVPixelFormat' from a -- video stream. Time is given in seconds from the start of the -- stream. frameReaderTime :: (MonadIO m, MonadError String m) => AVPixelFormat -> InputSource - -> m (IO (Maybe (AVFrame, Double)), IO (), Maybe AVDictionary) + -> m (IO (Maybe (AVFrame, Double)), IO (), VideoStreamMetadata) frameReaderTime dstFmt src = do inputContext <- openInput src checkStreams inputContext (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext - metadata <- structMetadata vidStream + metaAndSide <- extractVideoStreamMetadata vidStream _ <- openCodec ctx cod (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx AVRational num den <- liftIO $ getTimeBase vidStream @@ -252,7 +261,7 @@ frameReaderTime dstFmt src = Nothing -> return Nothing Just f -> do t <- frameTime' f return $ Just (f, t) - return (readTS, cleanup, metadata) + return (readTS, cleanup, metaAndSide) frameAudioReader :: (MonadIO m, MonadError String m) => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO (), Maybe AVDictionary) @@ -267,7 +276,7 @@ frameAudioReader fileName = do samplerate <- getSampleRate ctx channelLayout <- getChannelLayout ctx sampleFormat <- getSampleFormat ctx - channels <- getChannels channelLayout + let channels = numChannels channelLayout codecId <- getCodecID cod return $ AudioStream { asBitRate = bitrate @@ -285,7 +294,7 @@ frameAudioReader fileName = do -- -- > frameReaderT = fmap (first MaybeT) . frameReader frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m) - => InputSource -> m (MaybeT IO (AVFrame, Double), IO (), Maybe AVDictionary) + => InputSource -> m (MaybeT IO (AVFrame, Double), IO (), VideoStreamMetadata) frameReaderTimeT = fmap (first3 MaybeT) . frameReaderTime avPixFmtRgb24 prepareAudioReader :: (MonadIO m, MonadError String m) @@ -376,3 +385,21 @@ prepareReader fmtCtx vidStream dstFmt codCtx = else free_packet pkt >> getFrame else free_packet pkt >> getFrame return (getFrame `catchError` const (return Nothing), cleanup) + +getStreamSideData :: MonadIO m => AVStream -> m [AVPacketSideData] +getStreamSideData avstream = liftIO $ do + nbs <- fromIntegral <$> getNbSideData avstream + if nbs > 0 then do + sdArray <- getSideData avstream + peekArray nbs sdArray + else pure [] + +extractDisplayRotation :: MonadIO m => [AVPacketSideData] -> m (Maybe DisplayRotationDegrees) +extractDisplayRotation lst = go Nothing lst + where + go dsp@(Just _) _ = pure dsp + go Nothing (nextElem:xs) = liftIO (getDisplayRotation nextElem) + go anything [] = pure anything + + + diff --git a/src/Codec/FFmpeg/Display.hsc b/src/Codec/FFmpeg/Display.hsc new file mode 100644 index 0000000..c96e7fe --- /dev/null +++ b/src/Codec/FFmpeg/Display.hsc @@ -0,0 +1,56 @@ +{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +module Codec.FFmpeg.Display where + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Foreign.Marshal.Array (newArray) +import Data.Int (Int32) + +import Codec.FFmpeg.Types (AVPacketSideData (..), getPacketSideDataData, AVStream (..), getPacketSideDataType) +import Codec.FFmpeg.Enums (AVPacketSideDataType (..), avPktDataDisplaymatrix) +import Codec.FFmpeg.Common (av_malloc) + +#include +#include + +foreign import ccall unsafe "isnan" + isnan :: CDouble -> CInt + +-- double av_display_rotation_get(const int32_t matrix[9]); + +foreign import ccall "av_display_rotation_get" + av_display_rotation_get :: Ptr () -> IO CDouble + +type DisplayRotationDegrees = Integer + +getDisplayRotation :: AVPacketSideData -> IO (Maybe DisplayRotationDegrees) +getDisplayRotation avp = do + case getPacketSideDataType avp of + avPktDataDisplaymatrix -> do + ptr <- getPacketSideDataData avp + rot <- av_display_rotation_get ptr + pure $ if isnan rot > 0 then Nothing else Just (round rot) + _ -> pure Nothing + +displayRotationCSize :: CSize +displayRotationCSize = fromIntegral (sizeOf (1::CInt) * 9) + +newtype DisplayRotation = DisplayRotation (Ptr ()) deriving (Storable) + +foreign import ccall "av_display_rotation_set" + av_display_rotation_set :: DisplayRotation -> CDouble -> IO () + +setDisplayRotation :: Double -> IO DisplayRotation +setDisplayRotation angle = do + arr <- DisplayRotation <$> av_malloc displayRotationCSize + av_display_rotation_set arr (CDouble angle) + pure arr + +foreign import ccall "av_stream_add_side_data" + av_stream_add_side_data :: AVStream -> AVPacketSideDataType -> Ptr () -> CSize -> IO () + +addAsSideData :: AVStream -> DisplayRotation -> IO () +addAsSideData avs (DisplayRotation ptr) = av_stream_add_side_data avs avPktDataDisplaymatrix (castPtr ptr) displayRotationCSize diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc index bf7d658..8208b35 100644 --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -12,8 +12,9 @@ import Codec.FFmpeg.Internal.Linear import Codec.FFmpeg.Resampler import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types +import Codec.FFmpeg.Display import Codec.Picture -import Control.Monad (when, void) +import Control.Monad (when, void, forM_) import Data.Bits import Data.IORef import Data.Maybe (fromMaybe, isNothing) @@ -125,6 +126,7 @@ data EncodingParams = EncodingParams -- ^ 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@. + , epDisplayRotation :: Maybe DisplayRotation } -- | Minimal parameters describing the desired audio/video output. @@ -158,6 +160,7 @@ data AVEncodingParams = AVEncodingParams -- ^ 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@. + , avepDisplayRotation :: Maybe DisplayRotation } -- | Minimal parameters describing the desired audio/video output. @@ -189,6 +192,7 @@ data VideoParams = VideoParams , vpCodec :: Maybe AVCodecID , vpPixelFormat :: Maybe AVPixelFormat , vpPreset :: String + , vpDisplayRotation :: Maybe DisplayRotation } class HasVideoParams a where @@ -202,6 +206,7 @@ instance HasVideoParams EncodingParams where , vpCodec = epCodec ep , vpPixelFormat = epPixelFormat ep , vpPreset = epPreset ep + , vpDisplayRotation = epDisplayRotation ep } instance HasVideoParams AVEncodingParams where @@ -212,6 +217,7 @@ instance HasVideoParams AVEncodingParams where , vpCodec = avepCodec ep , vpPixelFormat = avepPixelFormat ep , vpPreset = avepPreset ep + , vpDisplayRotation = avepDisplayRotation ep } class HasAudioParams a where @@ -243,6 +249,7 @@ defaultH264 w h = , epPixelFormat = Nothing , epPreset = "medium" , epFormatName = Nothing + , epDisplayRotation = Nothing } -- | Use default parameters for a video of the given width and @@ -257,6 +264,7 @@ defaultParams w h = , epPixelFormat = Nothing , epPreset = "" , epFormatName = Nothing + , epDisplayRotation = Nothing } -- | Determine if the bitwise intersection of two values is non-zero. @@ -298,7 +306,7 @@ initVideoStream vp oc = do | codec == avCodecIdRawvideo -> avPixFmtRgb24 | codec == avCodecIdGif -> avPixFmtPal8 | otherwise -> avPixFmtYuv420p - + forM_ (vpDisplayRotation vp) $ \dispRot -> addAsSideData st dispRot -- Some formats want stream headers to be separate needsHeader <- checkFlag avfmtGlobalheader <$> (getOutputFormat oc >>= getFormatFlags) @@ -510,7 +518,7 @@ videoWriter ep fname = do data StreamParams = JustVideo VideoParams - | JustAudio AudioParams + | JustAudio AudioParams | AudioVideo AudioParams VideoParams withVideoParams :: StreamParams -> a -> (VideoParams -> a) -> a @@ -805,3 +813,5 @@ 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 index 5e29e4f..610b96c 100644 --- a/src/Codec/FFmpeg/Enums.hsc +++ b/src/Codec/FFmpeg/Enums.hsc @@ -5,10 +5,12 @@ import Foreign.C.Types import Foreign.Storable (Storable) #include +#include #include #include #include #include +#include #include #include #include "nameCompat.h" @@ -531,7 +533,7 @@ newtype AVSampleFormat = AVSampleFormat CInt deriving (Eq, Bits, Storable) getSampleFormatInt :: AVSampleFormat -> CInt getSampleFormatInt (AVSampleFormat i) = i -newtype AVChannelOrder = AVChannelOrder CInt deriving (Eq, Bits, Storable) +newtype AVChannelOrder = AVChannelOrder CInt deriving (Eq, Bits, Storable, Show) #enum AVChannelOrder, AVChannelOrder \ , AV_CHANNEL_ORDER_UNSPEC\ , AV_CHANNEL_ORDER_NATIVE\ @@ -569,4 +571,200 @@ c_AVERROR_EAGAIN :: CInt c_AVERROR_EAGAIN = #const AVERROR(EAGAIN) c_AVERROR_EOF :: CInt -c_AVERROR_EOF = #const AVERROR_EOF \ No newline at end of file +c_AVERROR_EOF = #const AVERROR_EOF + +newtype AVPacketSideDataType = AVPacketSideDataType CInt deriving (Eq, Bits, Storable) +#enum AVPacketSideDataType, AVPacketSideDataType \ + , AV_PKT_DATA_PALETTE \ + , AV_PKT_DATA_NEW_EXTRADATA \ + , AV_PKT_DATA_PARAM_CHANGE \ + , AV_PKT_DATA_H263_MB_INFO \ + , AV_PKT_DATA_REPLAYGAIN \ + , AV_PKT_DATA_DISPLAYMATRIX \ + , AV_PKT_DATA_STEREO3D \ + , AV_PKT_DATA_AUDIO_SERVICE_TYPE \ + , AV_PKT_DATA_QUALITY_STATS \ + , AV_PKT_DATA_FALLBACK_TRACK \ + , AV_PKT_DATA_CPB_PROPERTIES \ + , AV_PKT_DATA_SKIP_SAMPLES \ + , AV_PKT_DATA_JP_DUALMONO \ + , AV_PKT_DATA_STRINGS_METADATA \ + , AV_PKT_DATA_SUBTITLE_POSITION \ + , AV_PKT_DATA_MATROSKA_BLOCKADDITIONAL \ + , AV_PKT_DATA_WEBVTT_IDENTIFIER \ + , AV_PKT_DATA_WEBVTT_SETTINGS \ + , AV_PKT_DATA_METADATA_UPDATE \ + , AV_PKT_DATA_MPEGTS_STREAM_ID \ + , AV_PKT_DATA_MASTERING_DISPLAY_METADATA \ + , AV_PKT_DATA_SPHERICAL \ + , AV_PKT_DATA_CONTENT_LIGHT_LEVEL \ + , AV_PKT_DATA_A53_CC \ + , AV_PKT_DATA_ENCRYPTION_INIT_INFO \ + , AV_PKT_DATA_ENCRYPTION_INFO \ + , AV_PKT_DATA_AFD \ + , AV_PKT_DATA_PRFT \ + , AV_PKT_DATA_ICC_PROFILE \ + , AV_PKT_DATA_DOVI_CONF \ + , AV_PKT_DATA_S12M_TIMECODE \ + , AV_PKT_DATA_DYNAMIC_HDR10_PLUS \ + , AV_PKT_DATA_NB + +newtype AVChannel = AVChannel CInt deriving (Eq, Bits, Storable) +#enum AVChannel, AVChannel \ + , AV_CHAN_NONE \ + , AV_CHAN_FRONT_LEFT \ + , AV_CHAN_FRONT_RIGHT \ + , AV_CHAN_FRONT_CENTER \ + , AV_CHAN_LOW_FREQUENCY \ + , AV_CHAN_BACK_LEFT \ + , AV_CHAN_BACK_RIGHT \ + , AV_CHAN_FRONT_LEFT_OF_CENTER \ + , AV_CHAN_FRONT_RIGHT_OF_CENTER \ + , AV_CHAN_BACK_CENTER \ + , AV_CHAN_SIDE_LEFT \ + , AV_CHAN_SIDE_RIGHT \ + , AV_CHAN_TOP_CENTER \ + , AV_CHAN_TOP_FRONT_LEFT \ + , AV_CHAN_TOP_FRONT_CENTER \ + , AV_CHAN_TOP_FRONT_RIGHT \ + , AV_CHAN_TOP_BACK_LEFT \ + , AV_CHAN_TOP_BACK_CENTER \ + , AV_CHAN_TOP_BACK_RIGHT \ + , AV_CHAN_STEREO_LEFT \ + , AV_CHAN_STEREO_RIGHT \ + , AV_CHAN_WIDE_LEFT \ + , AV_CHAN_WIDE_RIGHT \ + , AV_CHAN_SURROUND_DIRECT_LEFT \ + , AV_CHAN_SURROUND_DIRECT_RIGHT \ + , AV_CHAN_LOW_FREQUENCY_2 \ + , AV_CHAN_TOP_SIDE_LEFT \ + , AV_CHAN_TOP_SIDE_RIGHT \ + , AV_CHAN_BOTTOM_FRONT_CENTER \ + , AV_CHAN_BOTTOM_FRONT_LEFT \ + , AV_CHAN_BOTTOM_FRONT_RIGHT \ + , AV_CHAN_UNUSED \ + , AV_CHAN_UNKNOWN \ + , AV_CHAN_AMBISONIC_BASE \ + , AV_CHAN_AMBISONIC_END + +cAV_CH_FRONT_LEFT :: CInt +cAV_CH_FRONT_RIGHT :: CInt +cAV_CH_FRONT_CENTER :: CInt +cAV_CH_LOW_FREQUENCY :: CInt +cAV_CH_BACK_LEFT :: CInt +cAV_CH_BACK_RIGHT :: CInt +cAV_CH_FRONT_LEFT_OF_CENTER :: CInt +cAV_CH_FRONT_RIGHT_OF_CENTER :: CInt +cAV_CH_BACK_CENTER :: CInt +cAV_CH_SIDE_LEFT :: CInt +cAV_CH_SIDE_RIGHT :: CInt +cAV_CH_TOP_CENTER :: CInt +cAV_CH_TOP_FRONT_LEFT :: CInt +cAV_CH_TOP_FRONT_CENTER :: CInt +cAV_CH_TOP_FRONT_RIGHT :: CInt +cAV_CH_TOP_BACK_LEFT :: CInt +cAV_CH_TOP_BACK_CENTER :: CInt +cAV_CH_TOP_BACK_RIGHT :: CInt +cAV_CH_STEREO_LEFT :: CInt +cAV_CH_STEREO_RIGHT :: CInt +cAV_CH_WIDE_LEFT :: CInt +cAV_CH_WIDE_RIGHT :: CInt +cAV_CH_SURROUND_DIRECT_LEFT :: CInt +cAV_CH_SURROUND_DIRECT_RIGHT :: CInt +cAV_CH_LOW_FREQUENCY_2 :: CInt +cAV_CH_TOP_SIDE_LEFT :: CInt +cAV_CH_TOP_SIDE_RIGHT :: CInt +cAV_CH_BOTTOM_FRONT_CENTER :: CInt +cAV_CH_BOTTOM_FRONT_LEFT :: CInt +cAV_CH_BOTTOM_FRONT_RIGHT :: CInt +cAV_CH_FRONT_LEFT = #const AV_CH_FRONT_LEFT +cAV_CH_FRONT_RIGHT = #const AV_CH_FRONT_RIGHT +cAV_CH_FRONT_CENTER = #const AV_CH_FRONT_CENTER +cAV_CH_LOW_FREQUENCY = #const AV_CH_LOW_FREQUENCY +cAV_CH_BACK_LEFT = #const AV_CH_BACK_LEFT +cAV_CH_BACK_RIGHT = #const AV_CH_BACK_RIGHT +cAV_CH_FRONT_LEFT_OF_CENTER = #const AV_CH_FRONT_LEFT_OF_CENTER +cAV_CH_FRONT_RIGHT_OF_CENTER = #const AV_CH_FRONT_RIGHT_OF_CENTER +cAV_CH_BACK_CENTER = #const AV_CH_BACK_CENTER +cAV_CH_SIDE_LEFT = #const AV_CH_SIDE_LEFT +cAV_CH_SIDE_RIGHT = #const AV_CH_SIDE_RIGHT +cAV_CH_TOP_CENTER = #const AV_CH_TOP_CENTER +cAV_CH_TOP_FRONT_LEFT = #const AV_CH_TOP_FRONT_LEFT +cAV_CH_TOP_FRONT_CENTER = #const AV_CH_TOP_FRONT_CENTER +cAV_CH_TOP_FRONT_RIGHT = #const AV_CH_TOP_FRONT_RIGHT +cAV_CH_TOP_BACK_LEFT = #const AV_CH_TOP_BACK_LEFT +cAV_CH_TOP_BACK_CENTER = #const AV_CH_TOP_BACK_CENTER +cAV_CH_TOP_BACK_RIGHT = #const AV_CH_TOP_BACK_RIGHT +cAV_CH_STEREO_LEFT = #const AV_CH_STEREO_LEFT +cAV_CH_STEREO_RIGHT = #const AV_CH_STEREO_RIGHT +cAV_CH_WIDE_LEFT = #const AV_CH_WIDE_LEFT +cAV_CH_WIDE_RIGHT = #const AV_CH_WIDE_RIGHT +cAV_CH_SURROUND_DIRECT_LEFT = #const AV_CH_SURROUND_DIRECT_LEFT +cAV_CH_SURROUND_DIRECT_RIGHT = #const AV_CH_SURROUND_DIRECT_RIGHT +cAV_CH_LOW_FREQUENCY_2 = #const AV_CH_LOW_FREQUENCY_2 +cAV_CH_TOP_SIDE_LEFT = #const AV_CH_TOP_SIDE_LEFT +cAV_CH_TOP_SIDE_RIGHT = #const AV_CH_TOP_SIDE_RIGHT +cAV_CH_BOTTOM_FRONT_CENTER = #const AV_CH_BOTTOM_FRONT_CENTER +cAV_CH_BOTTOM_FRONT_LEFT = #const AV_CH_BOTTOM_FRONT_LEFT +cAV_CH_BOTTOM_FRONT_RIGHT = #const AV_CH_BOTTOM_FRONT_RIGHT + + +cAV_CH_LAYOUT_MONO :: CUInt +cAV_CH_LAYOUT_STEREO :: CUInt +cAV_CH_LAYOUT_2POINT1 :: CUInt +cAV_CH_LAYOUT_2_1 :: CUInt +cAV_CH_LAYOUT_SURROUND :: CUInt +cAV_CH_LAYOUT_3POINT1 :: CUInt +cAV_CH_LAYOUT_4POINT0 :: CUInt +cAV_CH_LAYOUT_4POINT1 :: CUInt +cAV_CH_LAYOUT_2_2 :: CUInt +cAV_CH_LAYOUT_QUAD :: CUInt +cAV_CH_LAYOUT_5POINT0 :: CUInt +cAV_CH_LAYOUT_5POINT1 :: CUInt +cAV_CH_LAYOUT_5POINT0_BACK :: CUInt +cAV_CH_LAYOUT_5POINT1_BACK :: CUInt +cAV_CH_LAYOUT_6POINT0 :: CUInt +cAV_CH_LAYOUT_6POINT0_FRONT :: CUInt +cAV_CH_LAYOUT_HEXAGONAL :: CUInt +cAV_CH_LAYOUT_6POINT1 :: CUInt +cAV_CH_LAYOUT_6POINT1_BACK :: CUInt +cAV_CH_LAYOUT_6POINT1_FRONT :: CUInt +cAV_CH_LAYOUT_7POINT0 :: CUInt +cAV_CH_LAYOUT_7POINT0_FRONT :: CUInt +cAV_CH_LAYOUT_7POINT1 :: CUInt +cAV_CH_LAYOUT_7POINT1_WIDE :: CUInt +cAV_CH_LAYOUT_7POINT1_WIDE_BACK:: CUInt +cAV_CH_LAYOUT_OCTAGONAL :: CUInt +cAV_CH_LAYOUT_HEXADECAGONAL :: CUInt +cAV_CH_LAYOUT_STEREO_DOWNMIX :: CUInt +cAV_CH_LAYOUT_22POINT2 :: CUInt + +cAV_CH_LAYOUT_MONO = #const AV_CH_LAYOUT_MONO +cAV_CH_LAYOUT_STEREO = #const AV_CH_LAYOUT_STEREO +cAV_CH_LAYOUT_2POINT1 = #const AV_CH_LAYOUT_2POINT1 +cAV_CH_LAYOUT_2_1 = #const AV_CH_LAYOUT_2_1 +cAV_CH_LAYOUT_SURROUND = #const AV_CH_LAYOUT_SURROUND +cAV_CH_LAYOUT_3POINT1 = #const AV_CH_LAYOUT_3POINT1 +cAV_CH_LAYOUT_4POINT0 = #const AV_CH_LAYOUT_4POINT0 +cAV_CH_LAYOUT_4POINT1 = #const AV_CH_LAYOUT_4POINT1 +cAV_CH_LAYOUT_2_2 = #const AV_CH_LAYOUT_2_2 +cAV_CH_LAYOUT_QUAD = #const AV_CH_LAYOUT_QUAD +cAV_CH_LAYOUT_5POINT0 = #const AV_CH_LAYOUT_5POINT0 +cAV_CH_LAYOUT_5POINT1 = #const AV_CH_LAYOUT_5POINT1 +cAV_CH_LAYOUT_5POINT0_BACK = #const AV_CH_LAYOUT_5POINT0_BACK +cAV_CH_LAYOUT_5POINT1_BACK = #const AV_CH_LAYOUT_5POINT1_BACK +cAV_CH_LAYOUT_6POINT0 = #const AV_CH_LAYOUT_6POINT0 +cAV_CH_LAYOUT_6POINT0_FRONT = #const AV_CH_LAYOUT_6POINT0_FRONT +cAV_CH_LAYOUT_HEXAGONAL = #const AV_CH_LAYOUT_HEXAGONAL +cAV_CH_LAYOUT_6POINT1 = #const AV_CH_LAYOUT_6POINT1 +cAV_CH_LAYOUT_6POINT1_BACK = #const AV_CH_LAYOUT_6POINT1_BACK +cAV_CH_LAYOUT_6POINT1_FRONT = #const AV_CH_LAYOUT_6POINT1_FRONT +cAV_CH_LAYOUT_7POINT0 = #const AV_CH_LAYOUT_7POINT0 +cAV_CH_LAYOUT_7POINT0_FRONT = #const AV_CH_LAYOUT_7POINT0_FRONT +cAV_CH_LAYOUT_7POINT1 = #const AV_CH_LAYOUT_7POINT1 +cAV_CH_LAYOUT_7POINT1_WIDE = #const AV_CH_LAYOUT_7POINT1_WIDE +cAV_CH_LAYOUT_7POINT1_WIDE_BACK = #const AV_CH_LAYOUT_7POINT1_WIDE_BACK +cAV_CH_LAYOUT_OCTAGONAL = #const AV_CH_LAYOUT_OCTAGONAL +cAV_CH_LAYOUT_HEXADECAGONAL = #const AV_CH_LAYOUT_HEXADECAGONAL +cAV_CH_LAYOUT_STEREO_DOWNMIX = #const AV_CH_LAYOUT_STEREO_DOWNMIX +cAV_CH_LAYOUT_22POINT2 = #const AV_CH_LAYOUT_22POINT2 \ No newline at end of file diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index 84ecda4..1e4566a 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -1,47 +1,46 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + -- | Convert between FFmpeg frames and JuicyPixels images. module Codec.FFmpeg.Juicy where -import Codec.Picture + import Codec.FFmpeg.Common import Codec.FFmpeg.Decode import Codec.FFmpeg.Encode import Codec.FFmpeg.Enums +import Codec.FFmpeg.Internal.Linear (V2 (..)) import Codec.FFmpeg.Probe -import Codec.FFmpeg.Internal.Linear (V2(..)) import Codec.FFmpeg.Types +import Codec.Picture import Control.Monad.Except import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.Foldable (traverse_) +import Data.List.NonEmpty (NonEmpty, singleton, (<|)) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.Types import Foreign.Storable (sizeOf) -import Data.List.NonEmpty (NonEmpty, singleton, (<|)) - -- | Convert 'AVFrame' to a 'Vector'. frameToVector :: AVFrame -> IO (Maybe (V.Vector CUChar)) frameToVector = runMaybeT . frameToVectorT - -- | Convert 'AVFrame' to a 'Vector' with the result in the 'MaybeT' transformer. frameToVectorT :: AVFrame -> MaybeT IO (V.Vector CUChar) frameToVectorT frame = do - bufSize <- fromIntegral <$> frameBufferSizeT frame v <- MaybeT $ do + v <- VM.new bufSize - v <- VM.new bufSize - - VM.unsafeWith v (frameCopyToBuffer frame) - >>= return . maybe Nothing (const (Just v)) + VM.unsafeWith v (frameCopyToBuffer frame) + >>= return . maybe Nothing (const (Just v)) lift $ V.unsafeFreeze v - -- | Convert an 'AVFrame' to a 'DynamicImage' with the result in the -- 'MaybeT' transformer. -- @@ -49,54 +48,49 @@ frameToVectorT frame = do toJuicyT :: AVFrame -> MaybeT IO DynamicImage toJuicyT = MaybeT . toJuicy - -- | Convert an 'AVFrame' to a 'DynamicImage'. toJuicy :: AVFrame -> IO (Maybe DynamicImage) toJuicy frame = runMaybeT $ do - v <- frameToVectorT frame MaybeT $ do - w <- fromIntegral <$> getWidth frame h <- fromIntegral <$> getHeight frame - let mkImage :: V.Storable (PixelBaseComponent a) - => (Image a -> DynamicImage) -> Maybe DynamicImage + let mkImage :: + (V.Storable (PixelBaseComponent a)) => + (Image a -> DynamicImage) -> + Maybe DynamicImage mkImage c = Just $ c (Image w h (V.unsafeCast v)) fmt <- getPixelFormat frame return $ case () of - _ | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 - | fmt == avPixFmtGray8 -> mkImage ImageY8 - | fmt == avPixFmtGray16 -> mkImage ImageY16 - | otherwise -> Nothing - + _ + | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 + | fmt == avPixFmtGray8 -> mkImage ImageY8 + | fmt == avPixFmtGray16 -> mkImage ImageY16 + | otherwise -> Nothing -- | Convert an 'AVFrame' to an 'Image'. -toJuicyImage :: forall p. JuicyPixelFormat p => AVFrame -> IO (Maybe (Image p)) +toJuicyImage :: forall p. (JuicyPixelFormat p) => AVFrame -> IO (Maybe (Image p)) toJuicyImage frame = runMaybeT $ do - fmt <- lift $ getPixelFormat frame guard (fmt == juicyPixelFormat ([] :: [p])) MaybeT $ do - w <- fromIntegral <$> getWidth frame h <- fromIntegral <$> getHeight frame fmap (Image w h . V.unsafeCast) <$> frameToVector frame - -- | Save an 'AVFrame' to a PNG file on disk assuming the frame could -- be converted to a 'DynamicImage' using 'toJuicy'. saveJuicy :: FilePath -> AVFrame -> IO () saveJuicy name = toJuicy >=> traverse_ (savePngImage name) - -- | Mapping of @JuicyPixels@ pixel types to FFmpeg pixel formats. -class Pixel a => JuicyPixelFormat a where +class (Pixel a) => JuicyPixelFormat a where juicyPixelFormat :: proxy a -> AVPixelFormat instance JuicyPixelFormat Pixel8 where @@ -109,67 +103,73 @@ instance JuicyPixelFormat PixelRGBA8 where juicyPixelFormat _ = avPixFmtRgba -- | Bytes-per-pixel for a JuicyPixels 'Pixel' type. -juicyPixelStride :: forall a proxy. Pixel a => proxy a -> Int +juicyPixelStride :: forall a proxy. (Pixel a) => proxy a -> Int juicyPixelStride _ = sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a) type Metadata = NonEmpty (String, String) --- avDictionaryToMetadata :: MonadIO m => AVDictionary -> m (Maybe Metadata) --- avDictionaryToMetadata avdict = liftIO $ do --- nullStr <- newCString "" --- nonEmpty <$> checkKeyVal nullStr (AVDictionaryEntry nullPtr) [] --- where --- checkKeyVal nullStr prevEntry lst = do --- avde@(AVDictionaryEntry ptrres) <- av_dict_get avdict nullStr prevEntry av_dict_ignore_suffix --- if nullPtr == ptrres then pure lst else do --- key <- peekCString =<< getKey avde --- val <- peekCString =<< getValue avde --- checkKeyVal nullPtr prevEntry ((key, val) : lst) - -mapToResult :: (MonadIO m, JuicyPixelFormat p) => m (a1, b, Maybe AVDictionary) -> ((AVFrame -> IO (Maybe (Image p))) -> a1 -> MaybeT m2 a2) -> m (m2 (Maybe a2), b, Maybe Metadata) -mapToResult f aux = do +avDictionaryToKV :: (MonadIO m, JuicyPixelFormat p) => m (a1, b, Maybe AVDictionary) -> ((AVFrame -> IO (Maybe (Image p))) -> a1 -> MaybeT m2 a2) -> m (m2 (Maybe a2), b, Maybe Metadata) +avDictionaryToKV f aux = do (frame, cleanup, avdict) <- f let frameResult = runMaybeT (aux toJuicyImage frame) - metadata <- dictFoldM folder Nothing `mapM` avdict - pure (frameResult, cleanup, join metadata) + md <- dictFoldM folder Nothing `mapM` avdict + pure (frameResult, cleanup, join md) where folder Nothing kv = pure (Just (singleton kv)) folder (Just nes) kv = pure (Just (kv <| nes)) -- | Read frames from a video stream. -imageReaderT :: forall m p. - (Functor m, MonadIO m, MonadError String m, - JuicyPixelFormat p) - => InputSource -> m (IO (Maybe (Image p)), IO (), Maybe Metadata) -imageReaderT is = mapToResult (frameReader (juicyPixelFormat ([] :: [p])) is) aux - - --fmap (first3 (runMaybeT . aux toJuicyImage)) --- . frameReader (juicyPixelFormat ([] :: [p])) - where aux g x = MaybeT x >>= MaybeT . g +imageReaderT :: + forall m p. + ( Functor m, + MonadIO m, + MonadError String m, + JuicyPixelFormat p + ) => + InputSource -> + m (IO (Maybe (Image p)), IO (), VideoStreamMetadata) +imageReaderT = + fmap (first3 (runMaybeT . aux toJuicyImage)) + . frameReader (juicyPixelFormat ([] :: [p])) + where + aux g x = MaybeT x >>= MaybeT . g -- | Read frames from a video stream. Errors are thrown as -- 'IOException's. -imageReader :: JuicyPixelFormat p - => InputSource -> IO (IO (Maybe (Image p)), IO (), Maybe Metadata) +imageReader :: + (JuicyPixelFormat p) => + InputSource -> + IO (IO (Maybe (Image p)), IO (), VideoStreamMetadata) imageReader = either error return <=< (runExceptT . imageReaderT) -- | Read time stamped frames from a video stream. Time is given in -- seconds from the start of the stream. -imageReaderTimeT :: forall m p. - (Functor m, MonadIO m, MonadError String m, - JuicyPixelFormat p) - => InputSource -> m (IO (Maybe (Image p, Double)), IO (), Maybe Metadata) -imageReaderTimeT is = mapToResult (frameReaderTime (juicyPixelFormat ([] :: [p])) is) aux - where aux g x = do (f,t) <- MaybeT x - f' <- MaybeT $ g f - return (f', t) +imageReaderTimeT :: + forall m p. + ( Functor m, + MonadIO m, + MonadError String m, + JuicyPixelFormat p + ) => + InputSource -> + m (IO (Maybe (Image p, Double)), IO (), VideoStreamMetadata) +imageReaderTimeT = + fmap (first3 (runMaybeT . aux toJuicyImage)) + . frameReaderTime (juicyPixelFormat ([] :: [p])) + where + aux g x = do + (f, t) <- MaybeT x + f' <- MaybeT $ g f + return (f', t) -- | Read time stamped frames from a video stream. Time is given in -- seconds from the start of the stream. Errors are thrown as -- 'IOException's. -imageReaderTime :: JuicyPixelFormat p - => InputSource -> IO (IO (Maybe (Image p, Double)), IO (), Maybe Metadata) +imageReaderTime :: + (JuicyPixelFormat p) => + InputSource -> + IO (IO (Maybe (Image p, Double)), IO (), VideoStreamMetadata) imageReaderTime = either error return <=< runExceptT . imageReaderTimeT -- | Open a target file for writing a video stream. When the returned @@ -182,17 +182,24 @@ imageReaderTime = either error return <=< runExceptT . imageReaderTimeT -- (i.e. those that are handled by @libswscaler@). Practically, this -- means that animated gif output is only supported if the source -- images are of the target resolution. -imageWriter :: forall p. JuicyPixelFormat p - => EncodingParams -> FilePath -> IO (Maybe (Image p) -> IO ()) +imageWriter :: + forall p. + (JuicyPixelFormat p) => + EncodingParams -> + FilePath -> + IO (Maybe (Image p) -> IO ()) imageWriter ep f = do vw <- videoWriter ep f return $ (. fmap fromJuciy) vw -- | 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) +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 diff --git a/src/Codec/FFmpeg/Resampler.hs b/src/Codec/FFmpeg/Resampler.hs index 55caca8..93f0cdd 100644 --- a/src/Codec/FFmpeg/Resampler.hs +++ b/src/Codec/FFmpeg/Resampler.hs @@ -51,7 +51,7 @@ makeResampler ctx inParams outParams = do srcData = castPtr (hasData frame) dstDataPtr <- malloc lineSize <- malloc - dstChannelCount <- getChannels (apChannelLayout outParams) + let dstChannelCount = numChannels (apChannelLayout outParams) _ <- runWithError "Could not alloc samples" (av_samples_alloc_array_and_samples dstDataPtr lineSize dstChannelCount (fromIntegral dstSamples) @@ -114,12 +114,11 @@ initSwrContext inParams outParams = do _ <- av_opt_set_int (getPtr swr) cStr (fromIntegral i) 0 free cStr set_sample_fmt str fmt = withCString str $ \cStr -> av_opt_set_sample_fmt (getPtr swr) cStr fmt 0 - set_channel_layout str avchl = withCString str $ \cStr -> av_opt_set_chlayout (getPtr swr) cStr avchl 0 - void $ set_channel_layout "in_ch_layout" (apChannelLayout inParams) + void $ set_channel_layout swr "in_ch_layout" (apChannelLayout inParams) set_int "in_sample_rate" (apSampleRate inParams) void $ set_sample_fmt "in_sample_fmt" (apSampleFormat inParams) - void $ set_channel_layout "out_ch_layout" (apChannelLayout outParams) + void $ set_channel_layout swr "out_ch_layout" (apChannelLayout outParams) set_int "out_sample_rate" (apSampleRate outParams) void $ set_sample_fmt "out_sample_fmt" (apSampleFormat outParams) diff --git a/src/Codec/FFmpeg/Types.hsc b/src/Codec/FFmpeg/Types.hsc index 3c58ea6..c498ec8 100644 --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -79,14 +79,6 @@ foreign import ccall "avformat_alloc_context" mallocAVFormatContext :: IO AVFormatContext mallocAVFormatContext = AVFormatContext <$> avformat_alloc_context -newtype AVChannelLayout = AVChannelLayout (Ptr ()) deriving (Storable, HasPtr) - -#mkField ChannelOrder, AVChannelOrder -#mkField Channels, CInt - -#hasField AVChannelLayout, ChannelOrder, order -#hasField AVChannelLayout, Channels, nb_channels - newtype AVCodecContext = AVCodecContext (Ptr ()) deriving (Storable, HasPtr) foreign import ccall "avcodec_alloc_context3" @@ -124,7 +116,7 @@ foreign import ccall "avcodec_alloc_context3" #hasField AVCodecContext, TicksPerFrame, ticks_per_frame #hasField AVCodecContext, RawAspectRatio, sample_aspect_ratio #hasField AVCodecContext, SampleRate, sample_rate -#hasField AVCodecContext, ChannelLayout, channel_layout +#hasField AVCodecContext, ChannelLayout, ch_layout #hasField AVCodecContext, SampleFormat, sample_fmt #hasField AVCodecContext, FrameSize, frame_size #hasField AVCodecContext, FrameRate, framerate @@ -158,12 +150,24 @@ foreign import ccall "avcodec_parameters_to_context" -> AVCodecParameters -> IO CInt +newtype AVPacketSideData = AVPacketSideData (Ptr ()) deriving (Storable, HasPtr) + +#mkField PacketSideDataData, (Ptr ()) +#mkField PacketSideDataSize, CLong +#mkField PacketSideDataType, AVPacketSideDataType + +#hasField AVPacketSideData, PacketSideDataData, data +#hasField AVPacketSideData, PacketSideDataSize, size +#hasField AVPacketSideData, PacketSideDataType, type + newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) #mkField Id, CInt #mkField CodecContext, AVCodecContext #mkField StreamIndex, CInt #mkField CodecParams, AVCodecParameters #mkField Dictionary, AVDictionary +#mkField SideData, (Ptr (AVPacketSideData)) +#mkField NbSideData, CInt -- Update this to include side data & metadata in the structure @@ -172,13 +176,15 @@ newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) #hasField AVStream, StreamIndex, index #hasField AVStream, CodecParams, codecpar #hasField AVStream, Dictionary, metadata +#hasField AVStream, SideData, side_data +#hasField AVStream, NbSideData, nb_side_data 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 ChannelLayouts, (Ptr AVChannelLayout) #mkField SupportedSampleRates, (Ptr CInt) #mkField Capabilities, CInt @@ -187,7 +193,7 @@ newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) #hasField AVCodec, CodecID, id #hasField AVCodec, PixelFormats, pix_fmts #hasField AVCodec, SampleFormats, sample_fmts -#hasField AVCodec, ChannelLayouts, channel_layouts +#hasField AVCodec, ChannelLayouts, ch_layouts #hasField AVCodec, SupportedSampleRates, supported_samplerates #hasField AVCodec, Capabilities, capabilities @@ -402,3 +408,111 @@ data CameraConfig = defaultCameraConfig :: CameraConfig defaultCameraConfig = CameraConfig (Just 30) Nothing Nothing + +newtype AVChannelCustom = AVChannelCustom (Ptr ()) deriving (Storable, HasPtr) + +data AVChannelLayout = + AVChannelLayout { order :: AVChannelOrder + , numChannels :: CInt + , mask :: Either CUInt AVChannelCustom + } -- Ignore the union for now + +instance Storable AVChannelLayout where + sizeOf _ = #size AVChannelLayout + alignment _ = #size AVChannelLayout + peek ptr = do + ord <- (#peek AVChannelLayout, order) ptr + nc <- (#peek AVChannelLayout, nb_channels) ptr + maskCust <- if ord == avChannelOrderCustom then do + custPtr <- (#peek AVChannelLayout, u) ptr + Right <$> (AVChannelCustom <$> peek custPtr) + else + Left <$> (fromIntegral <$> peekULong) + pure (AVChannelLayout ord nc maskCust) + where + peekULong :: IO CUInt + peekULong = (#peek AVChannelLayout, u) ptr + + poke ptr (AVChannelLayout ord nc maskCustom) = do + (#poke AVChannelLayout, order) ptr ord + (#poke AVChannelLayout, nb_channels) ptr nc + case maskCustom of + Left msk -> (#poke AVChannelLayout, u) ptr msk + Right custom -> (#poke AVChannelLayout, u) ptr custom + + +foreign import ccall "av_channel_layout_default" + av_channel_layout_default :: Ptr () -> CInt -> IO () + +channelLayoutDefault :: Ptr () -> CInt -> IO AVChannelLayout +channelLayoutDefault ptr chans = do + av_channel_layout_default ptr chans + peek (castPtr ptr) + +sizeOfAVChannelLayout :: Int +sizeOfAVChannelLayout = #size AVChannelLayout + + +cAV_CHANNEL_LAYOUT_MASK :: CInt -> CUInt -> AVChannelLayout +cAV_CHANNEL_LAYOUT_MASK nb m = AVChannelLayout avChannelOrderNative nb (Left m) + +cAV_CHANNEL_LAYOUT_MONO :: AVChannelLayout +cAV_CHANNEL_LAYOUT_STEREO :: AVChannelLayout +cAV_CHANNEL_LAYOUT_2POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_2_1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_SURROUND :: AVChannelLayout +cAV_CHANNEL_LAYOUT_3POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_4POINT0 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_4POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_2_2 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_QUAD :: AVChannelLayout +cAV_CHANNEL_LAYOUT_5POINT0 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_5POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_5POINT0_BACK :: AVChannelLayout +cAV_CHANNEL_LAYOUT_5POINT1_BACK :: AVChannelLayout +cAV_CHANNEL_LAYOUT_6POINT0 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_6POINT0_FRONT :: AVChannelLayout +cAV_CHANNEL_LAYOUT_HEXAGONAL :: AVChannelLayout +cAV_CHANNEL_LAYOUT_6POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_6POINT1_BACK :: AVChannelLayout +cAV_CHANNEL_LAYOUT_6POINT1_FRONT :: AVChannelLayout +cAV_CHANNEL_LAYOUT_7POINT0 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_7POINT0_FRONT :: AVChannelLayout +cAV_CHANNEL_LAYOUT_7POINT1 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_7POINT1_WIDE :: AVChannelLayout +cAV_CHANNEL_LAYOUT_7POINT1_WIDE_BACK :: AVChannelLayout +cAV_CHANNEL_LAYOUT_OCTAGONAL :: AVChannelLayout +cAV_CHANNEL_LAYOUT_HEXADECAGONAL :: AVChannelLayout +cAV_CHANNEL_LAYOUT_STEREO_DOWNMIX :: AVChannelLayout +cAV_CHANNEL_LAYOUT_22POINT2 :: AVChannelLayout +cAV_CHANNEL_LAYOUT_AMBISONIC_FIRST_ORDER :: AVChannelLayout +cAV_CHANNEL_LAYOUT_MONO = cAV_CHANNEL_LAYOUT_MASK 1 cAV_CH_LAYOUT_MONO +cAV_CHANNEL_LAYOUT_STEREO = cAV_CHANNEL_LAYOUT_MASK 2 cAV_CH_LAYOUT_STEREO +cAV_CHANNEL_LAYOUT_2POINT1 = cAV_CHANNEL_LAYOUT_MASK 3 cAV_CH_LAYOUT_2POINT1 +cAV_CHANNEL_LAYOUT_2_1 = cAV_CHANNEL_LAYOUT_MASK 3 cAV_CH_LAYOUT_2_1 +cAV_CHANNEL_LAYOUT_SURROUND = cAV_CHANNEL_LAYOUT_MASK 3 cAV_CH_LAYOUT_SURROUND +cAV_CHANNEL_LAYOUT_3POINT1 = cAV_CHANNEL_LAYOUT_MASK 4 cAV_CH_LAYOUT_3POINT1 +cAV_CHANNEL_LAYOUT_4POINT0 = cAV_CHANNEL_LAYOUT_MASK 4 cAV_CH_LAYOUT_4POINT0 +cAV_CHANNEL_LAYOUT_4POINT1 = cAV_CHANNEL_LAYOUT_MASK 5 cAV_CH_LAYOUT_4POINT1 +cAV_CHANNEL_LAYOUT_2_2 = cAV_CHANNEL_LAYOUT_MASK 4 cAV_CH_LAYOUT_2_2 +cAV_CHANNEL_LAYOUT_QUAD = cAV_CHANNEL_LAYOUT_MASK 4 cAV_CH_LAYOUT_QUAD +cAV_CHANNEL_LAYOUT_5POINT0 = cAV_CHANNEL_LAYOUT_MASK 5 cAV_CH_LAYOUT_5POINT0 +cAV_CHANNEL_LAYOUT_5POINT1 = cAV_CHANNEL_LAYOUT_MASK 6 cAV_CH_LAYOUT_5POINT1 +cAV_CHANNEL_LAYOUT_5POINT0_BACK = cAV_CHANNEL_LAYOUT_MASK 5 cAV_CH_LAYOUT_5POINT0_BACK +cAV_CHANNEL_LAYOUT_5POINT1_BACK = cAV_CHANNEL_LAYOUT_MASK 6 cAV_CH_LAYOUT_5POINT1_BACK +cAV_CHANNEL_LAYOUT_6POINT0 = cAV_CHANNEL_LAYOUT_MASK 6 cAV_CH_LAYOUT_6POINT0 +cAV_CHANNEL_LAYOUT_6POINT0_FRONT = cAV_CHANNEL_LAYOUT_MASK 6 cAV_CH_LAYOUT_6POINT0_FRONT +cAV_CHANNEL_LAYOUT_HEXAGONAL = cAV_CHANNEL_LAYOUT_MASK 6 cAV_CH_LAYOUT_HEXAGONAL +cAV_CHANNEL_LAYOUT_6POINT1 = cAV_CHANNEL_LAYOUT_MASK 7 cAV_CH_LAYOUT_6POINT1 +cAV_CHANNEL_LAYOUT_6POINT1_BACK = cAV_CHANNEL_LAYOUT_MASK 7 cAV_CH_LAYOUT_6POINT1_BACK +cAV_CHANNEL_LAYOUT_6POINT1_FRONT = cAV_CHANNEL_LAYOUT_MASK 7 cAV_CH_LAYOUT_6POINT1_FRONT +cAV_CHANNEL_LAYOUT_7POINT0 = cAV_CHANNEL_LAYOUT_MASK 7 cAV_CH_LAYOUT_7POINT0 +cAV_CHANNEL_LAYOUT_7POINT0_FRONT = cAV_CHANNEL_LAYOUT_MASK 7 cAV_CH_LAYOUT_7POINT0_FRONT +cAV_CHANNEL_LAYOUT_7POINT1 = cAV_CHANNEL_LAYOUT_MASK 8 cAV_CH_LAYOUT_7POINT1 +cAV_CHANNEL_LAYOUT_7POINT1_WIDE = cAV_CHANNEL_LAYOUT_MASK 8 cAV_CH_LAYOUT_7POINT1_WIDE +cAV_CHANNEL_LAYOUT_7POINT1_WIDE_BACK = cAV_CHANNEL_LAYOUT_MASK 8 cAV_CH_LAYOUT_7POINT1_WIDE_BACK +cAV_CHANNEL_LAYOUT_OCTAGONAL = cAV_CHANNEL_LAYOUT_MASK 8 cAV_CH_LAYOUT_OCTAGONAL +cAV_CHANNEL_LAYOUT_HEXADECAGONAL = cAV_CHANNEL_LAYOUT_MASK 16 cAV_CH_LAYOUT_HEXADECAGONAL +cAV_CHANNEL_LAYOUT_STEREO_DOWNMIX = cAV_CHANNEL_LAYOUT_MASK 2 cAV_CH_LAYOUT_STEREO_DOWNMIX +cAV_CHANNEL_LAYOUT_22POINT2 = cAV_CHANNEL_LAYOUT_MASK 24 cAV_CH_LAYOUT_22POINT2 +cAV_CHANNEL_LAYOUT_AMBISONIC_FIRST_ORDER = AVChannelLayout avChannelOrderAmbisonic 4 (Left 0) From f8432d208ba4047495a6f42042a136cbea4a1e7a Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Thu, 28 Mar 2024 01:26:34 +1100 Subject: [PATCH 3/9] Add rotation capability to image reader and video writer --- demo/Main.hs | 13 +++---- ffmpeg-light.cabal | 1 + src/Codec/FFmpeg/Decode.hs | 8 +++-- src/Codec/FFmpeg/Display.hsc | 10 +++--- src/Codec/FFmpeg/Encode.hsc | 2 ++ src/Codec/FFmpeg/Juicy.hs | 70 ++++++++++++++++++++---------------- src/Codec/FFmpeg/Types.hsc | 33 ++++++++++------- 7 files changed, 81 insertions(+), 56 deletions(-) diff --git a/demo/Main.hs b/demo/Main.hs index 243b877..b3b41d5 100644 --- a/demo/Main.hs +++ b/demo/Main.hs @@ -11,7 +11,7 @@ import Control.Monad (unless) -- The example used in the README firstFrame :: IO (Maybe DynamicImage) firstFrame = do initFFmpeg - (getFrame, cleanup, maybeMetadata) <- imageReader (File "myVideo.mov") + (getFrame, cleanup, maybeMetadata) <- imageReader False (File "myVideo.mov") (fmap ImageRGB8 <$> getFrame) <* cleanup -- | Generate a video that pulses from light to dark. @@ -42,8 +42,8 @@ testDecode :: FilePath -> IO () testDecode vidFile = do initFFmpeg - setLogLevel avLogTrace - (getFrame, cleanup, maybeMetadata) <- imageReaderTime (File vidFile) + -- setLogLevel avLogTrace + (getFrame, cleanup, maybeMetadata) <- imageReaderTime True (File vidFile) frame1 <- getFrame case frame1 of Just (avf,ts) -> do putStrLn $ "Frame at "++show ts @@ -73,7 +73,7 @@ testCamera = do initFFmpeg -- Defaults to quiet (minimal) logging -- setLogLevel avLogInfo -- Restore standard ffmpeg logging - (getFrame, cleanup, maybeMetadata) <- imageReader $ + (getFrame, cleanup, maybeMetadata) <- imageReader False $ case Info.os of "linux" -> let cfg = CameraConfig (Just 30) Nothing (Just "mjpeg") @@ -106,8 +106,9 @@ main = do args <- getArgs where usage = unlines [ "Usage: demo [videoFile]" , " If no argument is given, a test video named " - , " pulse.mov is generated." + , " pulse.mov is generated with side data of 90 degree rotation." , "" , " If a file name is given, then two frames are " , " extracted: the first frame, and the 301st." - , " These are saved to frame1.png and frame2.png" ] + , " These are saved to frame1.png and frame2.png." + , " If the video has rotation then these frame are corrected" ] diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal index 91e3d47..4e79ee4 100644 --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -88,6 +88,7 @@ library transformers >= 0.4.1 && < 0.7, mtl >= 2.2.1 && < 2.4, JuicyPixels >= 3.1 && < 3.4, + JuicyPixels-extra >= 0.6.0, bytestring, containers diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index c641d00..2593ca0 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -270,7 +270,7 @@ frameAudioReader fileName = do checkStreams inputContext (audioStreamIndex, ctx, cod, audioStream) <- findAudioStream inputContext metadata <- structMetadata audioStream - openCodec ctx cod + void (openCodec ctx cod) as <- liftIO $ do bitrate <- getBitRate ctx samplerate <- getSampleRate ctx @@ -398,7 +398,11 @@ extractDisplayRotation :: MonadIO m => [AVPacketSideData] -> m (Maybe DisplayRot extractDisplayRotation lst = go Nothing lst where go dsp@(Just _) _ = pure dsp - go Nothing (nextElem:xs) = liftIO (getDisplayRotation nextElem) + go Nothing (nextElem:xs) = do + disprm <- liftIO (getDisplayRotation nextElem) + case disprm of + Nothing -> go Nothing xs + Just dispr -> pure (Just dispr) go anything [] = pure anything diff --git a/src/Codec/FFmpeg/Display.hsc b/src/Codec/FFmpeg/Display.hsc index c96e7fe..d330aed 100644 --- a/src/Codec/FFmpeg/Display.hsc +++ b/src/Codec/FFmpeg/Display.hsc @@ -9,7 +9,7 @@ import Foreign.C.Types import Foreign.Marshal.Array (newArray) import Data.Int (Int32) -import Codec.FFmpeg.Types (AVPacketSideData (..), getPacketSideDataData, AVStream (..), getPacketSideDataType) +import Codec.FFmpeg.Types (AVPacketSideData (..), AVStream (..)) import Codec.FFmpeg.Enums (AVPacketSideDataType (..), avPktDataDisplaymatrix) import Codec.FFmpeg.Common (av_malloc) @@ -28,10 +28,10 @@ type DisplayRotationDegrees = Integer getDisplayRotation :: AVPacketSideData -> IO (Maybe DisplayRotationDegrees) getDisplayRotation avp = do - case getPacketSideDataType avp of - avPktDataDisplaymatrix -> do - ptr <- getPacketSideDataData avp - rot <- av_display_rotation_get ptr + case tipe avp of + avPktDataDisplaymatrix -> do + rot <- av_display_rotation_get (data_ avp) + print rot pure $ if isnan rot > 0 then Nothing else Just (round rot) _ -> pure Nothing diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc index 8208b35..475305c 100644 --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -127,6 +127,8 @@ data EncodingParams = EncodingParams -- from the output file name. If 'Just', the string value -- should be the one available in @ffmpeg -formats@. , epDisplayRotation :: Maybe DisplayRotation + -- ^ Display rotation side data to enable frame rotation. + -- Will likely be Nothing when video has no rotation } -- | Minimal parameters describing the desired audio/video output. diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index 1e4566a..5ace772 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -10,7 +10,6 @@ import Codec.FFmpeg.Decode import Codec.FFmpeg.Encode import Codec.FFmpeg.Enums import Codec.FFmpeg.Internal.Linear (V2 (..)) -import Codec.FFmpeg.Probe import Codec.FFmpeg.Types import Codec.Picture import Control.Monad.Except @@ -18,11 +17,13 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.Foldable (traverse_) -import Data.List.NonEmpty (NonEmpty, singleton, (<|)) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.Types import Foreign.Storable (sizeOf) +import Codec.FFmpeg.Display (DisplayRotationDegrees) +import Codec.Picture.Extra (rotate180, rotateRight90, rotateLeft90) -- | Convert 'AVFrame' to a 'Vector'. frameToVector :: AVFrame -> IO (Maybe (V.Vector CUChar)) @@ -73,16 +74,25 @@ toJuicy frame = runMaybeT $ do | otherwise -> Nothing -- | Convert an 'AVFrame' to an 'Image'. -toJuicyImage :: forall p. (JuicyPixelFormat p) => AVFrame -> IO (Maybe (Image p)) -toJuicyImage frame = runMaybeT $ do +-- | Rotate it if display rotation is available as side data +toJuicyImage :: forall p. (JuicyPixelFormat p) => Bool -> Maybe DisplayRotationDegrees -> AVFrame -> IO (Maybe (Image p)) +toJuicyImage rotateIfPres mdisp frame = runMaybeT $ do fmt <- lift $ getPixelFormat frame guard (fmt == juicyPixelFormat ([] :: [p])) + w <- lift $ fromIntegral <$> getWidth frame + h <- lift $ fromIntegral <$> getHeight frame - MaybeT $ do - w <- fromIntegral <$> getWidth frame - h <- fromIntegral <$> getHeight frame + img <- MaybeT $ fmap (Image w h . V.unsafeCast) <$> frameToVector frame + maybe (pure img) (pure . rotate img) (if rotateIfPres then mdisp else Nothing) + +rotate :: forall p. (JuicyPixelFormat p) => Image p -> DisplayRotationDegrees -> Image p +rotate img rotation + | abs rotation >= 180 = rotate180 img + | rotation == (-90) = rotateRight90 img + | rotation == 90 = rotateLeft90 img + -- TODO handle this exception case + | otherwise = img - fmap (Image w h . V.unsafeCast) <$> frameToVector frame -- | Save an 'AVFrame' to a PNG file on disk assuming the frame could -- be converted to a 'DynamicImage' using 'toJuicy'. @@ -109,16 +119,6 @@ juicyPixelStride _ = type Metadata = NonEmpty (String, String) -avDictionaryToKV :: (MonadIO m, JuicyPixelFormat p) => m (a1, b, Maybe AVDictionary) -> ((AVFrame -> IO (Maybe (Image p))) -> a1 -> MaybeT m2 a2) -> m (m2 (Maybe a2), b, Maybe Metadata) -avDictionaryToKV f aux = do - (frame, cleanup, avdict) <- f - let frameResult = runMaybeT (aux toJuicyImage frame) - md <- dictFoldM folder Nothing `mapM` avdict - pure (frameResult, cleanup, join md) - where - folder Nothing kv = pure (Just (singleton kv)) - folder (Just nes) kv = pure (Just (kv <| nes)) - -- | Read frames from a video stream. imageReaderT :: forall m p. @@ -127,21 +127,27 @@ imageReaderT :: MonadError String m, JuicyPixelFormat p ) => + Bool -> InputSource -> m (IO (Maybe (Image p)), IO (), VideoStreamMetadata) -imageReaderT = - fmap (first3 (runMaybeT . aux toJuicyImage)) - . frameReader (juicyPixelFormat ([] :: [p])) +imageReaderT mdisp is = do + (r, c, md) <- frameReader (juicyPixelFormat ([] :: [p])) is + pure (aux md r, c, md) + -- fmap (first3 (runMaybeT . aux (toJuicyImage mdisp))) + -- . frameReader (juicyPixelFormat ([] :: [p])) where - aux g x = MaybeT x >>= MaybeT . g + aux md r = runMaybeT $ do + frame <- MaybeT r + MaybeT $ toJuicyImage mdisp (displayRotation md) frame -- | Read frames from a video stream. Errors are thrown as -- 'IOException's. imageReader :: (JuicyPixelFormat p) => + Bool -> InputSource -> IO (IO (Maybe (Image p)), IO (), VideoStreamMetadata) -imageReader = either error return <=< (runExceptT . imageReaderT) +imageReader mdisp = either error return <=< (runExceptT . imageReaderT mdisp) -- | Read time stamped frames from a video stream. Time is given in -- seconds from the start of the stream. @@ -152,25 +158,27 @@ imageReaderTimeT :: MonadError String m, JuicyPixelFormat p ) => + Bool -> InputSource -> m (IO (Maybe (Image p, Double)), IO (), VideoStreamMetadata) -imageReaderTimeT = - fmap (first3 (runMaybeT . aux toJuicyImage)) - . frameReaderTime (juicyPixelFormat ([] :: [p])) +imageReaderTimeT mdisp is = do + (r, c, md) <- frameReaderTime (juicyPixelFormat ([] :: [p])) is + pure (aux md r, c, md) where - aux g x = do - (f, t) <- MaybeT x - f' <- MaybeT $ g f - return (f', t) + aux md r = runMaybeT $ do + (frame, ts) <- MaybeT r + frame' <- MaybeT $ toJuicyImage mdisp (displayRotation md) frame + return (frame', ts) -- | Read time stamped frames from a video stream. Time is given in -- seconds from the start of the stream. Errors are thrown as -- 'IOException's. imageReaderTime :: (JuicyPixelFormat p) => + Bool -> InputSource -> IO (IO (Maybe (Image p, Double)), IO (), VideoStreamMetadata) -imageReaderTime = either error return <=< runExceptT . imageReaderTimeT +imageReaderTime mdisp = either error return <=< runExceptT . imageReaderTimeT mdisp -- | Open a target file for writing a video stream. When the returned -- function is applied to 'Nothing', the output stream is closed. Note diff --git a/src/Codec/FFmpeg/Types.hsc b/src/Codec/FFmpeg/Types.hsc index c498ec8..f8788ec 100644 --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -150,23 +150,32 @@ foreign import ccall "avcodec_parameters_to_context" -> AVCodecParameters -> IO CInt -newtype AVPacketSideData = AVPacketSideData (Ptr ()) deriving (Storable, HasPtr) - -#mkField PacketSideDataData, (Ptr ()) -#mkField PacketSideDataSize, CLong -#mkField PacketSideDataType, AVPacketSideDataType - -#hasField AVPacketSideData, PacketSideDataData, data -#hasField AVPacketSideData, PacketSideDataSize, size -#hasField AVPacketSideData, PacketSideDataType, type - +data AVPacketSideData = AVPacketSideData { + data_ :: Ptr (), + size :: CSize, + tipe :: AVPacketSideDataType +} + +instance Storable AVPacketSideData where + sizeOf _ = #size AVPacketSideData + alignment _ = #size AVPacketSideData + peek ptr = AVPacketSideData + <$> (#peek AVPacketSideData, data) ptr + <*> (#peek AVPacketSideData, size) ptr + <*> (#peek AVPacketSideData, type) ptr + + poke ptr (AVPacketSideData dta sz t) = do + (#poke AVPacketSideData, data) ptr dta + (#poke AVPacketSideData, size) ptr sz + (#poke AVPacketSideData, type) ptr t + newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) #mkField Id, CInt #mkField CodecContext, AVCodecContext #mkField StreamIndex, CInt #mkField CodecParams, AVCodecParameters #mkField Dictionary, AVDictionary -#mkField SideData, (Ptr (AVPacketSideData)) +#mkField SideData, (Ptr AVPacketSideData) #mkField NbSideData, CInt -- Update this to include side data & metadata in the structure @@ -415,7 +424,7 @@ data AVChannelLayout = AVChannelLayout { order :: AVChannelOrder , numChannels :: CInt , mask :: Either CUInt AVChannelCustom - } -- Ignore the union for now + } instance Storable AVChannelLayout where sizeOf _ = #size AVChannelLayout From 4f4013f63edaeade3797f52e3592c2b379065a71 Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Sun, 31 Mar 2024 00:06:41 +1100 Subject: [PATCH 4/9] Correct the decoding API using ffplay so that frames are not corrupted --- src/Codec/FFmpeg/Decode.hs | 36 +++++++++++++++++------------------- src/Codec/FFmpeg/Juicy.hs | 2 -- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index 2593ca0..553dff1 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -355,17 +355,15 @@ prepareReader fmtCtx vidStream dstFmt codCtx = free (getPtr pkt) -- This function follows the steps from https://ffmpeg.org/doxygen/trunk/group__lavc__encdec.html getFrame = do - readFrameCheck fmtCtx pkt - whichStream <- getStreamIndex pkt - if whichStream == vidStream - then do - frameReady <- avcodec_send_packet codCtx pkt - if frameReady == c_AVERROR_EAGAIN then do - -- Frame is ready to read - avcodec_receive_frame codCtx fRaw -- TODO: non zero is an error here - -- Send the packet to the decoder - avcodec_send_packet codCtx pkt -- TODO: non zero is an error here - + recvdFrame <- avcodec_receive_frame codCtx fRaw + if recvdFrame == c_AVERROR_EAGAIN then do + readFrameCheck fmtCtx pkt + whichStream <- getStreamIndex pkt + if whichStream == vidStream then do + avcodec_send_packet codCtx pkt -- TODO: non zero is an error here + free_packet pkt + getFrame + -- Some streaming codecs require a final flush with -- an empty packet -- fin' <- alloca $ \fin2 -> do @@ -374,16 +372,16 @@ prepareReader fmtCtx vidStream dstFmt codCtx = -- (#poke AVPacket, size) pkt (0::CInt) -- decode_video codCtx fRaw fin2 pkt -- peek fin2 + else free_packet pkt >> getFrame + else do + _ <- swsScale sws fRaw fRgb - _ <- swsScale sws fRaw fRgb - - -- Copy the raw frame's timestamp to the RGB frame - getPktDts fRaw >>= setPts fRgb + -- Copy the raw frame's timestamp to the RGB frame + getPktDts fRaw >>= setPts fRgb - free_packet pkt - return $ Just fRgb - else free_packet pkt >> getFrame - else free_packet pkt >> getFrame + free_packet pkt + return $ Just fRgb + return (getFrame `catchError` const (return Nothing), cleanup) getStreamSideData :: MonadIO m => AVStream -> m [AVPacketSideData] diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index 5ace772..fec0aab 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -13,8 +13,6 @@ import Codec.FFmpeg.Internal.Linear (V2 (..)) import Codec.FFmpeg.Types import Codec.Picture import Control.Monad.Except -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.Foldable (traverse_) import Data.List.NonEmpty (NonEmpty) From 2573767785ff93c0f612b782bd50cca9c416c3fe Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Sun, 31 Mar 2024 20:18:18 +1100 Subject: [PATCH 5/9] Fix build for 9.4 and 9.6 and tidy up code for pull request --- demo/AudioSin.hs | 1 + demo/Main.hs | 2 +- demo/Transcode.hs | 2 +- demo/VPlay.hs | 3 ++- ffmpeg-light.cabal | 2 +- src/Codec/FFmpeg/Common.hsc | 4 ++- src/Codec/FFmpeg/Decode.hs | 1 + src/Codec/FFmpeg/Display.hsc | 7 ++--- src/Codec/FFmpeg/Encode.hsc | 52 +++++++++++++++--------------------- src/Codec/FFmpeg/Juicy.hs | 5 ++-- src/Codec/FFmpeg/Probe.hsc | 7 ----- 11 files changed, 36 insertions(+), 50 deletions(-) diff --git a/demo/AudioSin.hs b/demo/AudioSin.hs index 7d7f317..8a5e8d5 100644 --- a/demo/AudioSin.hs +++ b/demo/AudioSin.hs @@ -17,6 +17,7 @@ import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import System.Environment +import Control.Monad (forM_, when) -- Simple Music DSL type Sound = Float -> Float diff --git a/demo/Main.hs b/demo/Main.hs index b3b41d5..992a383 100644 --- a/demo/Main.hs +++ b/demo/Main.hs @@ -11,7 +11,7 @@ import Control.Monad (unless) -- The example used in the README firstFrame :: IO (Maybe DynamicImage) firstFrame = do initFFmpeg - (getFrame, cleanup, maybeMetadata) <- imageReader False (File "myVideo.mov") + (getFrame, cleanup, _) <- imageReader False (File "myVideo.mov") (fmap ImageRGB8 <$> getFrame) <* cleanup -- | Generate a video that pulses from light to dark. diff --git a/demo/Transcode.hs b/demo/Transcode.hs index a690412..be5c393 100644 --- a/demo/Transcode.hs +++ b/demo/Transcode.hs @@ -34,7 +34,7 @@ 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) + (getFrame, cleanup, _) <- FF.imageReader False (FF.File from) putFrame <- FF.imageWriter ep to loop getFrame cleanup putFrame (\x -> return x) diff --git a/demo/VPlay.hs b/demo/VPlay.hs index 4cbf873..05d305c 100644 --- a/demo/VPlay.hs +++ b/demo/VPlay.hs @@ -7,10 +7,11 @@ import Codec.FFmpeg.Common import Codec.FFmpeg.Decode hiding (av_malloc) import Control.Concurrent.MVar (newMVar, takeMVar, putMVar) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Except import Control.Monad.Loops import Control.Monad.Trans.Maybe +import Control.Monad (when) import Data.ByteString (ByteString) import Data.ByteString.Unsafe (unsafePackCStringFinalizer) diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal index 4e79ee4..97fdc44 100644 --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -28,7 +28,7 @@ category: Codec build-type: Simple extra-source-files: src/hscMacros.h, src/nameCompat.h, CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.11 +tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.4 source-repository head type: git diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc index ff31bdc..e0406e4 100644 --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -158,10 +158,11 @@ runWithError msg toRun = do when (r < 0) (getError msg r) return r +getError :: [Char] -> CInt -> IO b getError msg r = 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) + _ <- av_strerror r errCStr (fromIntegral len) errStr <- peekCString errCStr free errCStr avError $ msg ++ " : " ++ errStr @@ -354,6 +355,7 @@ listSupportedSampleRates codec = do first3 :: (t -> a) -> (t, b, c) -> (a, b, c) first3 f (a,b,c) = (f a,b,c) +set_channel_layout :: HasPtr a => a -> String -> AVChannelLayout -> IO CInt set_channel_layout target str avchl = alloca $ \chlayoutPtr -> do poke chlayoutPtr avchl diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index 553dff1..6b60391 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -14,6 +14,7 @@ import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types import Codec.FFmpeg.Display import Control.Monad.Except +import Control.Monad (when, void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Maybe import Foreign.C.String diff --git a/src/Codec/FFmpeg/Display.hsc b/src/Codec/FFmpeg/Display.hsc index d330aed..4b790ab 100644 --- a/src/Codec/FFmpeg/Display.hsc +++ b/src/Codec/FFmpeg/Display.hsc @@ -6,8 +6,6 @@ module Codec.FFmpeg.Display where import Foreign.Ptr import Foreign.Storable import Foreign.C.Types -import Foreign.Marshal.Array (newArray) -import Data.Int (Int32) import Codec.FFmpeg.Types (AVPacketSideData (..), AVStream (..)) import Codec.FFmpeg.Enums (AVPacketSideDataType (..), avPktDataDisplaymatrix) @@ -28,12 +26,11 @@ type DisplayRotationDegrees = Integer getDisplayRotation :: AVPacketSideData -> IO (Maybe DisplayRotationDegrees) getDisplayRotation avp = do - case tipe avp of - avPktDataDisplaymatrix -> do + if tipe avp == avPktDataDisplaymatrix then do rot <- av_display_rotation_get (data_ avp) print rot pure $ if isnan rot > 0 then Nothing else Just (round rot) - _ -> pure Nothing + else pure Nothing displayRotationCSize :: CSize displayRotationCSize = fromIntegral (sizeOf (1::CInt) * 9) diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc index 475305c..7cf17b7 100644 --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -17,7 +17,7 @@ import Codec.Picture import Control.Monad (when, void, forM_) import Data.Bits import Data.IORef -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe) import Data.Ord (comparing) import Data.Traversable (for) import Data.Vector.Storable (Vector) @@ -27,7 +27,6 @@ import Foreign.C.String 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 @@ -320,10 +319,6 @@ initVideoStream vp oc = do getCodecFlags ctx >>= setCodecFlags ctx . (.|. avCodecFlagGlobalHeader) #endif - -- _ <- withCString "vprofile" $ \kStr -> - -- withCString (preset ep) $ \vStr -> - -- av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx)) - -- kStr vStr 0 when (not . null $ vpPreset vp) . void $ withCString "preset" $ \kStr -> withCString (vpPreset vp) $ \vStr -> @@ -333,7 +328,7 @@ initVideoStream vp oc = do when (rOpen < 0) (error "Couldn't open codec") codecParams <- getCodecParams st - runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) + _ <- runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) return (st, ctx) @@ -360,10 +355,10 @@ initAudioStream params oc = do setChannelLayout ctx (apChannelLayout params) - runWithError "Could not open audio codec" (open_codec ctx cod nullPtr) + _ <- 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) + _ <- runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) #if LIBAVFORMAT_VERSION_MAJOR < 57 getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader) @@ -401,10 +396,10 @@ allocOutputContext outputFormat fname = do Nothing -> (\f -> f nullPtr) oc <- alloca $ \ocTmp -> do r <- withCString fname $ \fname' -> - withFormat $ \format -> + withFormat $ \fmt -> avformat_alloc_output_context2 ocTmp (AVOutputFormat nullPtr) - format fname' + fmt fname' when (r < 0) (error "Couldn't allocate output format context") peek ocTmp @@ -429,7 +424,6 @@ avio_close_check oc = do r <- getIOContext oc >>= avio_close encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool encode_video_check ctx pkt frame = do - --r <- avcodec_encode_video2 ctx pkt frame' gotOutput r <- avcodec_send_frame ctx frame' if (r == 0 || r == c_AVERROR_EAGAIN) then do e <- avcodec_receive_packet ctx pkt @@ -566,10 +560,9 @@ avWriter :: Maybe String -> IO AVWriterContext avWriter outputFormat sp fname = do oc <- allocOutputContext outputFormat fname - outputFormat <- getOutputFormat oc - audioCodecId <- getAudioCodecID outputFormat - videoCodecId <- getVideoCodecID outputFormat - + oFormat <- getOutputFormat oc + audioCodecId <- getAudioCodecID oFormat + -- 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. @@ -579,7 +572,6 @@ avWriter outputFormat sp fname = do (Just <$> initAudioStream ap oc) avio_open_check oc fname - numStreams <- getNumStreams oc withCString fname (\str -> av_dump_format oc 0 str 1) write_header_check oc @@ -618,8 +610,7 @@ avWriter outputFormat sp fname = do 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 @@ -727,10 +718,9 @@ avWriter outputFormat sp fname = do return go initializeAudio :: AVStream - -> AVCodec -> AVCodecContext -> IO (Maybe AVFrame -> IO ()) - initializeAudio st codec ctx = do + initializeAudio st ctx = do if audioCodecId /= avCodecIdNone then do pkt <- av_packet_alloc @@ -753,14 +743,14 @@ avWriter outputFormat sp fname = do -- 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" + _ <- 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 + _ <- codec_close ctx return () writeAudioFrame (Just frame) = writeAudioFrame' frame @@ -777,29 +767,29 @@ avWriter outputFormat sp fname = do modifyIORef lastPts (const newPts) modifyIORef frameNum (+ fromIntegral numSamples) - runWithError "Error encoding audio" + _ <- runWithError "Error encoding audio" (avcodec_send_frame ctx frame) read_pkts return writeAudioFrame else return $ \_ -> return () - videoWriter <- case mVideoStream of + vWriter <- case mVideoStream of Just (vs, ctx) -> withVideoParams sp (return (\_ -> return ())) (initializeVideo vs ctx) Nothing -> return (\_ -> return ()) - audioWriter <- case mAudioStream of + aWriter <- case mAudioStream of Just (as, codec, ctx) -> withAudioParams sp (return $ \_ -> return ()) - (const (initializeAudio as codec ctx)) + (const (initializeAudio as ctx)) Nothing -> return $ \_ -> return () return $ AVWriterContext { avwVideoCodecContext = snd <$> mVideoStream , avwAudioCodecContext = (\(_, _, ctx) -> ctx) <$> mAudioStream - , avwVideoWriter = videoWriter - , avwAudioWriter = audioWriter + , avwVideoWriter = vWriter + , avwAudioWriter = aWriter } -- | Open a target file for writing a video stream. The function @@ -813,7 +803,7 @@ frameWriterRgb :: EncodingParams -> FilePath -> IO (Maybe (Vector CUChar) -> IO ()) frameWriterRgb ep f = do let aux pixels = (avPixFmtRgb24, V2 (epWidth ep) (epHeight ep), pixels) - videoWriter <- frameWriter ep f - return $ \pix -> videoWriter (aux <$> pix) + vWriter <- frameWriter ep f + return $ \pix -> vWriter (aux <$> pix) diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index fec0aab..810bae3 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -22,6 +22,9 @@ import Foreign.C.Types import Foreign.Storable (sizeOf) import Codec.FFmpeg.Display (DisplayRotationDegrees) import Codec.Picture.Extra (rotate180, rotateRight90, rotateLeft90) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad (guard, (>=>), (<=<)) -- | Convert 'AVFrame' to a 'Vector'. frameToVector :: AVFrame -> IO (Maybe (V.Vector CUChar)) @@ -131,8 +134,6 @@ imageReaderT :: imageReaderT mdisp is = do (r, c, md) <- frameReader (juicyPixelFormat ([] :: [p])) is pure (aux md r, c, md) - -- fmap (first3 (runMaybeT . aux (toJuicyImage mdisp))) - -- . frameReader (juicyPixelFormat ([] :: [p])) where aux md r = runMaybeT $ do frame <- MaybeT r diff --git a/src/Codec/FFmpeg/Probe.hsc b/src/Codec/FFmpeg/Probe.hsc index ccd77e9..0dfedbb 100644 --- a/src/Codec/FFmpeg/Probe.hsc +++ b/src/Codec/FFmpeg/Probe.hsc @@ -98,13 +98,6 @@ withStream sid f = nbStreams >>= \ns -> if sid >= ns streams <- liftIO $ (#peek AVFormatContext, streams) (getPtr ctx) liftIO (peekElemOff streams sid) >>= runReaderT (unAvStreamT f) --- codecContext :: MonadIO m => AvStreamT m (Maybe AVCodecContext) --- codecContext = do --- p <- ask >>= (liftIO . (#peek AVStream, codec) . getPtr) --- if (p /= nullPtr) --- then return $ Just $ AVCodecContext p --- else return Nothing - codecMediaTypeName :: MonadIO m => AVCodecContext -> AvStreamT m String codecMediaTypeName cctx = liftIO $ (#peek AVCodecContext, codec_type) (getPtr cctx) >>= From 29e957c60d571c5a75e1343bbd8da40c87fde6be Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Sun, 31 Mar 2024 21:02:43 +1100 Subject: [PATCH 6/9] Fix limits to restore support for 8.8.x and 8.10.x --- ffmpeg-light.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal index 97fdc44..cd2a6dd 100644 --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -28,7 +28,7 @@ category: Codec build-type: Simple extra-source-files: src/hscMacros.h, src/nameCompat.h, CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 9.2.8 || == 9.4.8 || == 9.6.4 +tested-with: GHC == 8.8.4 || == 8.10.7 || == 9.2.8 || == 9.4.8 || == 9.6.4 source-repository head type: git @@ -88,7 +88,7 @@ library transformers >= 0.4.1 && < 0.7, mtl >= 2.2.1 && < 2.4, JuicyPixels >= 3.1 && < 3.4, - JuicyPixels-extra >= 0.6.0, + JuicyPixels-extra >= 0.5.2, bytestring, containers @@ -163,4 +163,4 @@ executable audio-sin hs-source-dirs: demo main-is: AudioSin.hs default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall From 9d3e3fc26812022d0b8a3013440f75517be3ef48 Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Fri, 5 Apr 2024 20:01:16 +1100 Subject: [PATCH 7/9] AV_CODEC_FLAG_TRUNCATED was deprecated in 5 and removed in 6 --- src/Codec/FFmpeg/Enums.hsc | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Codec/FFmpeg/Enums.hsc b/src/Codec/FFmpeg/Enums.hsc index 610b96c..cce918f 100644 --- a/src/Codec/FFmpeg/Enums.hsc +++ b/src/Codec/FFmpeg/Enums.hsc @@ -456,7 +456,6 @@ newtype CodecFlag = CodecFlag CInt deriving (Eq, Bits, Storable) , AV_CODEC_FLAG_LOOP_FILTER\ , AV_CODEC_FLAG_GRAY\ , AV_CODEC_FLAG_PSNR\ - , AV_CODEC_FLAG_TRUNCATED\ , AV_CODEC_FLAG_INTERLACED_DCT\ , AV_CODEC_FLAG_LOW_DELAY\ , AV_CODEC_FLAG_GLOBAL_HEADER\ From d093dd101aa8a8fc1353f3ad4799eace13158165 Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Sun, 14 Apr 2024 18:00:15 +1000 Subject: [PATCH 8/9] Simplify toJuicyImage to only accept the optional display rotation and remove extra whitespace --- src/Codec/FFmpeg/Encode.hsc | 3 +-- src/Codec/FFmpeg/Juicy.hs | 25 ++++++++++++++----------- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Codec/FFmpeg/Encode.hsc b/src/Codec/FFmpeg/Encode.hsc index 7cf17b7..9a80c34 100644 --- a/src/Codec/FFmpeg/Encode.hsc +++ b/src/Codec/FFmpeg/Encode.hsc @@ -514,7 +514,7 @@ videoWriter ep fname = do data StreamParams = JustVideo VideoParams - | JustAudio AudioParams + | JustAudio AudioParams | AudioVideo AudioParams VideoParams withVideoParams :: StreamParams -> a -> (VideoParams -> a) -> a @@ -574,7 +574,6 @@ avWriter outputFormat sp fname = do avio_open_check oc fname withCString fname (\str -> av_dump_format oc 0 str 1) write_header_check oc - alreadyClosedRef <- newIORef False let writeClose = do alreadyClosed <- readIORef alreadyClosedRef diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs index 810bae3..9ba1e7f 100644 --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -76,15 +76,15 @@ toJuicy frame = runMaybeT $ do -- | Convert an 'AVFrame' to an 'Image'. -- | Rotate it if display rotation is available as side data -toJuicyImage :: forall p. (JuicyPixelFormat p) => Bool -> Maybe DisplayRotationDegrees -> AVFrame -> IO (Maybe (Image p)) -toJuicyImage rotateIfPres mdisp frame = runMaybeT $ do +toJuicyImage :: forall p. (JuicyPixelFormat p) => Maybe DisplayRotationDegrees -> AVFrame -> IO (Maybe (Image p)) +toJuicyImage mdisp frame = runMaybeT $ do fmt <- lift $ getPixelFormat frame guard (fmt == juicyPixelFormat ([] :: [p])) w <- lift $ fromIntegral <$> getWidth frame h <- lift $ fromIntegral <$> getHeight frame img <- MaybeT $ fmap (Image w h . V.unsafeCast) <$> frameToVector frame - maybe (pure img) (pure . rotate img) (if rotateIfPres then mdisp else Nothing) + maybe (pure img) (pure . rotate img) mdisp rotate :: forall p. (JuicyPixelFormat p) => Image p -> DisplayRotationDegrees -> Image p rotate img rotation @@ -120,7 +120,11 @@ juicyPixelStride _ = type Metadata = NonEmpty (String, String) --- | Read frames from a video stream. +rotateImage :: JuicyPixelFormat p => Bool -> VideoStreamMetadata -> AVFrame -> MaybeT IO (Image p) +rotateImage rotateIfPresent md = MaybeT . toJuicyImage (if rotateIfPresent then displayRotation md else Nothing) + +-- | Read frames from a video stream. Optionally rotate the image +-- if display rotation metadata is present imageReaderT :: forall m p. ( Functor m, @@ -131,13 +135,11 @@ imageReaderT :: Bool -> InputSource -> m (IO (Maybe (Image p)), IO (), VideoStreamMetadata) -imageReaderT mdisp is = do +imageReaderT rotateIfPresent is = do (r, c, md) <- frameReader (juicyPixelFormat ([] :: [p])) is pure (aux md r, c, md) where - aux md r = runMaybeT $ do - frame <- MaybeT r - MaybeT $ toJuicyImage mdisp (displayRotation md) frame + aux md r = runMaybeT $ MaybeT r >>= rotateImage rotateIfPresent md -- | Read frames from a video stream. Errors are thrown as -- 'IOException's. @@ -149,7 +151,8 @@ imageReader :: imageReader mdisp = either error return <=< (runExceptT . imageReaderT mdisp) -- | Read time stamped frames from a video stream. Time is given in --- seconds from the start of the stream. +-- seconds from the start of the stream. Optionally rotate the image +-- if display rotation metadata is present imageReaderTimeT :: forall m p. ( Functor m, @@ -160,13 +163,13 @@ imageReaderTimeT :: Bool -> InputSource -> m (IO (Maybe (Image p, Double)), IO (), VideoStreamMetadata) -imageReaderTimeT mdisp is = do +imageReaderTimeT rotateIfPresent is = do (r, c, md) <- frameReaderTime (juicyPixelFormat ([] :: [p])) is pure (aux md r, c, md) where aux md r = runMaybeT $ do (frame, ts) <- MaybeT r - frame' <- MaybeT $ toJuicyImage mdisp (displayRotation md) frame + frame' <- rotateImage rotateIfPresent md frame return (frame', ts) -- | Read time stamped frames from a video stream. Time is given in From 2891ed626ea0e681cbfee94b48ab338bbdac702b Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Sat, 27 Apr 2024 12:22:51 +1000 Subject: [PATCH 9/9] Remove libc isnan dependancy and use isNaN instead as in musl isnan is a #define. Add alpine container build to ensure build succeeds on musl. --- Containerfile-alpine | 26 ++++++++++++++++++++++++++ src/Codec/FFmpeg/Decode.hs | 2 +- src/Codec/FFmpeg/Display.hsc | 5 +---- 3 files changed, 28 insertions(+), 5 deletions(-) create mode 100644 Containerfile-alpine diff --git a/Containerfile-alpine b/Containerfile-alpine new file mode 100644 index 0000000..5d5e1ca --- /dev/null +++ b/Containerfile-alpine @@ -0,0 +1,26 @@ +# To build this container run +# docker build --build-arg STRIPE_SECRET= --build-arg RECAPTCHA_SECRET= \ +# --build-arg PG_DATABASE_URL="host=host.docker.internal user=docker password=docker dbname=test" \ +# --add-host=host.docker.internal:host-gateway -f/home/sumit/dev/matrixid/matrixid-api-server-bin/deploy/Containerised/Containerfile . +# Make sure the database on the host has a docker user with password docker and a database test +# To run the container a docker volume is required for video storage +# docker volume create image-store +# and run the image with --mount source=image-store,target=/tmp + +FROM docker.io/alpine:3.19 as builder + +RUN apk update && apk add binutils-gold curl gcc g++ gmp-dev libc-dev zlib-dev libffi-dev make musl-dev ncurses-dev perl tar xz git pkgconf mercurial sudo openssl libpq-dev ffmpeg-dev gettext + +RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=9.4.8 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 sh + +COPY . /build/ffmpeg-light + +WORKDIR /build/ffmpeg-light + +RUN --mount=type=cache,target=/root/.cabal/ . /root/.ghcup/env && ghcup install cabal latest +RUN --mount=type=cache,target=/root/.cabal/ . /root/.ghcup/env && ghcup set cabal latest +RUN --mount=type=cache,target=/root/.cabal/ . /root/.ghcup/env && cabal update +RUN --mount=type=cache,target=/root/.cabal/ . /root/.ghcup/env && cabal build --dependencies-only all +RUN --mount=type=cache,target=/root/.cabal/ . /root/.ghcup/env && cabal build -fBuildAudioExtractDemo -fBuildAudioSinDemo -fBuildDemo -fBuildRasterDemo -fBuildTranscodeDemo + +CMD /bin/sh \ No newline at end of file diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs index 6b60391..0908096 100644 --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -394,7 +394,7 @@ getStreamSideData avstream = liftIO $ do else pure [] extractDisplayRotation :: MonadIO m => [AVPacketSideData] -> m (Maybe DisplayRotationDegrees) -extractDisplayRotation lst = go Nothing lst +extractDisplayRotation = go Nothing where go dsp@(Just _) _ = pure dsp go Nothing (nextElem:xs) = do diff --git a/src/Codec/FFmpeg/Display.hsc b/src/Codec/FFmpeg/Display.hsc index 4b790ab..cf32e5d 100644 --- a/src/Codec/FFmpeg/Display.hsc +++ b/src/Codec/FFmpeg/Display.hsc @@ -11,11 +11,8 @@ import Codec.FFmpeg.Types (AVPacketSideData (..), AVStream (..)) import Codec.FFmpeg.Enums (AVPacketSideDataType (..), avPktDataDisplaymatrix) import Codec.FFmpeg.Common (av_malloc) -#include #include -foreign import ccall unsafe "isnan" - isnan :: CDouble -> CInt -- double av_display_rotation_get(const int32_t matrix[9]); @@ -29,7 +26,7 @@ getDisplayRotation avp = do if tipe avp == avPktDataDisplaymatrix then do rot <- av_display_rotation_get (data_ avp) print rot - pure $ if isnan rot > 0 then Nothing else Just (round rot) + pure $ if isNaN rot then Nothing else Just (round rot) else pure Nothing displayRotationCSize :: CSize