diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,25 @@ +0.8 +--- + +* Update to transformers-0.4.1 and mtl-2.2.1 + * Changed decode-related types to accomodate deprecation of the + `Error` class. This means that if you want to initialize decoders + in your own transformer stack that has a `MonadError` instance, + you will need to use the variants with names suffixed by a "T" + (for transformer). + +* Update to ffmpeg 2.3 + + * Address deprecation warning + + `Using AVStream.codec.time_base as a timebase hint to the muxer is + deprecated. Set AVStream.time_base instead.` + + * Address "non-strictly-monotonic PTS" warning + +* Rasterific bump + * Rasterific exports its own linear algebra types as of 0.3 + 0.7.1 --- diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -1,7 +1,7 @@ import Codec.FFmpeg import Codec.Picture import Control.Applicative -import Control.Monad.Error +import Control.Monad (replicateM_) import qualified Data.Vector.Storable as V import System.Environment diff --git a/demo/Raster.hs b/demo/Raster.hs --- a/demo/Raster.hs +++ b/demo/Raster.hs @@ -3,9 +3,9 @@ import Codec.Picture import Control.Monad (forM_) import Graphics.Rasterific +import Graphics.Rasterific.Linear import Graphics.Rasterific.Texture import Graphics.Rasterific.Transformations -import Linear -- | The Rasterific logo sample shape. logo :: Int -> Bool -> Vector -> [Primitive] @@ -36,7 +36,7 @@ | otherwise = let q0 = a + v1 ^* t q1 = b + v2 ^* t vq = q1 - q0 - in q0 + t *^ vq : (go $! t + 0.05) + in q0 + vq ^* t : (go $! t + 0.05) -- | Our animation path. path :: [Point] diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -1,5 +1,5 @@ name: ffmpeg-light -version: 0.7.1.1 +version: 0.8 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -15,7 +15,7 @@ > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" > (fmap ImageRGB8 <$> getFrame) <* cleanup . - Tested on OS X 10.9.2 with 2.2.1 + Tested on OS X 10.9.4 with 2.3 installed via . license: BSD3 @@ -56,8 +56,8 @@ build-tools: hsc2hs build-depends: base >=4.6 && < 5, vector >= 0.10.9 && < 0.11, - transformers >= 0.3 && < 0.5, - mtl >= 2.1.3 && < 2.3, + transformers >= 0.4.1 && < 0.5, + mtl >= 2.2.1 && < 2.3, JuicyPixels >= 3.1 && < 3.2 pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale hs-source-dirs: src @@ -81,7 +81,7 @@ buildable: False build-depends: base < 5, vector, mtl, transformers, JuicyPixels if flag(BuildRasterDemo) - build-depends: ffmpeg-light, Rasterific, linear + build-depends: ffmpeg-light, Rasterific >= 0.3 hs-source-dirs: demo main-is: Raster.hs default-language: Haskell2010 diff --git a/src/Codec/FFmpeg.hs b/src/Codec/FFmpeg.hs --- a/src/Codec/FFmpeg.hs +++ b/src/Codec/FFmpeg.hs @@ -5,6 +5,7 @@ initFFmpeg, -- * Decoding imageReader, imageReaderTime, + imageReaderT, imageReaderTimeT, -- * Encoding EncodingParams(..), defaultParams, imageWriter, -- * Types and Enums diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -51,12 +51,9 @@ -- | Catch an IOException from an IO action and re-throw it in a -- wrapping monad transformer. -wrapIOError :: (MonadIO m, Error e, MonadError e m) => IO a -> m a -wrapIOError = liftIO . flip catchError (errMsg . show) - --- | Throw an error with a 'String' message. -errMsg :: (Error e, MonadError e m) => String -> m a -errMsg = throwError . strMsg +wrapIOError :: (MonadIO m, MonadError String m) => IO a -> m a +wrapIOError io = liftIO (catchError (fmap Right io) (return . Left . show)) + >>= either throwError return -- * Wrappers that may throw 'IOException's. @@ -64,7 +61,7 @@ frame_alloc_check :: IO AVFrame frame_alloc_check = do r <- av_frame_alloc when (getPtr r == nullPtr) - (errMsg "Couldn't allocate frame") + (error "Couldn't allocate frame") return r -- | Allocate new buffer(s) for audio or video data with the required @@ -75,7 +72,7 @@ frame_get_buffer_check :: AVFrame -> CInt -> IO () frame_get_buffer_check f x = do r <- av_frame_get_buffer f x when (r /= 0) - (errMsg "Failed to allocate buffers") + (error "Failed to allocate buffers") -- | Bytes-per-pixel for an 'AVPixelFormat' avPixelStride :: AVPixelFormat -> Maybe Int diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -61,12 +61,12 @@ -- * FFmpeg Decoding Interface -- | Open an input media file. -openInput :: (MonadIO m, Error e, MonadError e m) => String -> m AVFormatContext +openInput :: (MonadIO m, MonadError String m) => String -> m AVFormatContext openInput filename = wrapIOError . alloca $ \ctx -> withCString filename $ \cstr -> do r <- avformat_open_input ctx cstr nullPtr nullPtr - when (r /= 0) (errMsg "Error opening file") + when (r /= 0) (error "Error opening file") peek ctx -- | @AVFrame@ is a superset of @AVPicture@, so we can upcast an @@ -75,30 +75,30 @@ frameAsPicture = AVPicture . getPtr -- | Find a codec given by name. -findDecoder :: (MonadIO m, Error e, MonadError e m) => String -> m AVCodec +findDecoder :: (MonadIO m, MonadError String m) => String -> m AVCodec findDecoder name = do r <- liftIO $ withCString name avcodec_find_decoder_by_name when (getPtr r == nullPtr) - (errMsg $ "Unsupported codec: " ++ show name) + (throwError $ "Unsupported codec: " ++ show name) return r -- | Read packets of a media file to get stream information. This is -- useful for file formats with no headers such as MPEG. -checkStreams :: (MonadIO m, Error e, MonadError e m) => AVFormatContext -> m () +checkStreams :: (MonadIO m, MonadError String m) => AVFormatContext -> m () checkStreams ctx = do r <- liftIO $ avformat_find_stream_info ctx nullPtr - when (r < 0) (errMsg "Couldn't find stream information") + when (r < 0) (throwError "Couldn't find stream information") -- | Searches for a video stream in an 'AVFormatContext'. If one is -- found, returns the index of the stream in the container, and its -- associated 'AVCodecContext' and 'AVCodec'. -findVideoStream :: (MonadIO m, Error e, MonadError e m) +findVideoStream :: (MonadIO m, MonadError String m) => AVFormatContext -> m (CInt, AVCodecContext, AVCodec) findVideoStream fmt = do wrapIOError . alloca $ \codec -> do poke codec (AVCodec nullPtr) i <- av_find_best_stream fmt avmediaTypeVideo (-1) (-1) codec 0 - when (i < 0) (errMsg "Couldn't find a video stream") + when (i < 0) (error "Couldn't find a video stream") cod <- peek codec streams <- getStreams fmt vidStream <- peek (advancePtr streams (fromIntegral i)) @@ -107,30 +107,30 @@ -- | Find a registered decoder with a codec ID matching that found in -- the given 'AVCodecContext'. -getDecoder :: (MonadIO m, Error e, MonadError e m) +getDecoder :: (MonadIO m, MonadError String m) => AVCodecContext -> m AVCodec getDecoder ctx = do p <- liftIO $ getCodecID ctx >>= avcodec_find_decoder - when (getPtr p == nullPtr) (errMsg "Unsupported codec") + when (getPtr p == nullPtr) (throwError "Unsupported codec") return p -- | Initialize the given 'AVCodecContext' to use the given -- 'AVCodec'. **NOTE**: This function is not thread safe! -openCodec :: (MonadIO m, Error e, MonadError e m) +openCodec :: (MonadIO m, MonadError String m) => AVCodecContext -> AVCodec -> m AVDictionary openCodec ctx cod = wrapIOError . alloca $ \dict -> do poke dict (AVDictionary nullPtr) r <- open_codec ctx cod dict - when (r < 0) (errMsg "Couldn't open decoder") + when (r < 0) (error "Couldn't open decoder") peek dict -- | Return the next frame of a stream. read_frame_check :: AVFormatContext -> AVPacket -> IO () read_frame_check ctx pkt = do r <- av_read_frame ctx pkt - when (r < 0) (errMsg "Frame read failed") + when (r < 0) (error "Frame read failed") -- | Read frames of the given 'AVPixelFormat' from a video stream. -frameReader :: (MonadIO m, Error e, MonadError e m) +frameReader :: (MonadIO m, MonadError String m) => AVPixelFormat -> FilePath -> m (IO (Maybe AVFrame), IO ()) frameReader dstFmt fileName = do inputContext <- openInput fileName @@ -142,14 +142,14 @@ -- | Read RGB frames with the result in the 'MaybeT' transformer. -- -- > frameReaderT = fmap (first MaybeT) . frameReader -frameReaderT :: (Functor m, MonadIO m, Error e, MonadError e m) +frameReaderT :: (Functor m, MonadIO m, MonadError String m) => FilePath -> m (MaybeT IO AVFrame, IO ()) frameReaderT = fmap (first 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, Error e, MonadError e m) +frameReaderTime :: (MonadIO m, MonadError String m) => AVPixelFormat -> FilePath -> m (IO (Maybe (AVFrame, Double)), IO ()) frameReaderTime dstFmt fileName = @@ -174,13 +174,13 @@ -- transformer. -- -- > frameReaderT = fmap (first MaybeT) . frameReader -frameReaderTimeT :: (Functor m, MonadIO m, Error e, MonadError e m) +frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m) => FilePath -> m (MaybeT IO (AVFrame, Double), IO ()) frameReaderTimeT = fmap (first MaybeT) . frameReaderTime avPixFmtRgb24 -- | Construct an action that gets the next available frame, and an -- action to release all resources associated with this video stream. -prepareReader :: (MonadIO m, Error e, MonadError e m) +prepareReader :: (MonadIO m, MonadError String m) => AVFormatContext -> CInt -> AVPixelFormat -> AVCodecContext -> m (IO (Maybe AVFrame), IO ()) prepareReader fmtCtx vidStream dstFmt codCtx = diff --git a/src/Codec/FFmpeg/Encode.hs b/src/Codec/FFmpeg/Encode.hs --- a/src/Codec/FFmpeg/Encode.hs +++ b/src/Codec/FFmpeg/Encode.hs @@ -14,7 +14,6 @@ import Codec.Picture import Control.Applicative import Control.Monad (when, void) -import Control.Monad.Error.Class import Data.Bits import Data.IORef import Data.Maybe (fromMaybe) @@ -140,23 +139,23 @@ initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext) initStream ep _ | (epWidth ep `rem` 2, epHeight ep `rem` 2) /= (0,0) = - throwError $ strMsg "Video dimensions must be multiples of two" + error "Video dimensions must be multiples of two" initStream ep oc = do -- Use the codec suggested by the output format, or override with -- the user's choice. codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (epCodec ep) cod <- avcodec_find_encoder codec when (getPtr cod == nullPtr) - (errMsg "Couldn't find encoder") + (error "Couldn't find encoder") st <- avformat_new_stream oc cod getNumStreams oc >>= setId st . subtract 1 - + let framePeriod = AVRational 1 (fromIntegral $ epFps ep) + setTimeBase st framePeriod ctx <- getCodecContext st setWidth ctx (epWidth ep) setHeight ctx (epHeight ep) - let framePeriod = AVRational 1 (fromIntegral $ epFps ep) - setTimeBase ctx framePeriod + -- setTimeBase ctx framePeriod setPixelFormat ctx $ case epPixelFormat ep of Just fmt -> fmt Nothing @@ -180,7 +179,7 @@ getPrivData ctx >>= \pd -> av_opt_set pd kStr vStr 0 rOpen <- open_codec ctx cod nullPtr - when (rOpen < 0) (throwError $ strMsg "Couldn't open codec") + when (rOpen < 0) (error "Couldn't open codec") return (st, ctx) @@ -198,7 +197,7 @@ -- For palettized images, we will provide our own buffer. if fmt == avPixFmtRgb8 || fmt == avPixFmtPal8 then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (epWidth ep) - when (r < 0) (errMsg "Error filling temporary frame line sizes") + when (r < 0) (error "Error filling temporary frame line sizes") else frame_get_buffer_check frame 32 return frame @@ -212,10 +211,10 @@ ocTmp (AVOutputFormat nullPtr) nullPtr fname' when (r < 0) - (errMsg "Couldn't allocate output format context") + (error "Couldn't allocate output format context") peek ocTmp when (getPtr oc == nullPtr) - (errMsg "Couldn't allocate output AVFormatContext") + (error "Couldn't allocate output AVFormatContext") return oc -- | Open the given file for writing. @@ -223,12 +222,12 @@ avio_open_check oc fname = do r <- withCString fname $ \cstr -> avio_open (hasIOContext oc) cstr avioFlagWrite - when (r < 0) (errMsg "Error opening IO for writing") + when (r < 0) (error "Error opening IO for writing") -- | Close an open IO context. avio_close_check :: AVFormatContext -> IO () avio_close_check oc = do r <- getIOContext oc >>= avio_close - when (r /= 0) (errMsg "Error closing IO") + when (r /= 0) (error "Error closing IO") -- | Returns 'True' if the 'AVPacket' was updated with new output -- data; 'False' otherwise. @@ -236,7 +235,7 @@ encode_video_check ctx pkt frame = alloca $ \gotOutput -> do r <- avcodec_encode_video2 ctx pkt frame' gotOutput - when (r < 0) (errMsg "Error encoding frame") + when (r < 0) (error "Error encoding frame") (> 0) <$> peek gotOutput where frame' = fromMaybe (AVFrame nullPtr) frame @@ -244,19 +243,19 @@ -- an output media file. write_header_check :: AVFormatContext -> IO () write_header_check oc = do r <- avformat_write_header oc nullPtr - when (r < 0) (errMsg "Error writing header") + when (r < 0) (error "Error writing header") -- | Write a packet to an output media file. write_frame_check :: AVFormatContext -> AVPacket -> IO () write_frame_check oc pkt = do r <- av_write_frame oc pkt - when (r < 0) (errMsg "Error writing frame") + when (r < 0) (error "Error writing frame") -- | Write the stream trailer to an output media file and free the -- private data. May only be called after a successful call to -- 'write_header_check'. write_trailer_check :: AVFormatContext -> IO () write_trailer_check oc = do r <- av_write_trailer oc - when (r /= 0) (errMsg "Error writing trailer") + when (r /= 0) (error "Error writing trailer") -- | Quantize RGB24 pixels to the systematic RGB8 color palette. The -- image data has space for a palette appended to be compliant with @@ -322,13 +321,19 @@ else return Nothing pkt <- AVPacket <$> av_malloc (fromIntegral packetSize) + setPts pkt 0 stIndex <- getStreamIndex st avio_open_check oc fname write_header_check oc + let framePeriod = AVRational 1 (fromIntegral $ epFps ep) + + -- The stream time_base can be changed by the call to + -- 'write_header_check', so we read it back here to establish a way + -- of scaling the nominal, desired frame rate (given by + -- 'framePeriod') to the stream's time_base. tb <- getTimeBase st - codecTB <- getCodecContext st >>= getTimeBase isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) let checkPalCompat @@ -341,7 +346,7 @@ palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy ep | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 ep | otherwise = Nothing - frameTime = av_rescale_q 1 codecTB tb + frameTime = av_rescale_q 1 framePeriod tb resetPacket = do init_packet pkt setData pkt nullPtr setSize pkt 0 @@ -366,9 +371,10 @@ getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey) --setSize pkt (fromIntegral $ V.length pixels) setSize pkt (fromIntegral pictureSize) - getPts dstFrame >>= setPts dstFrame . (+ frameTime) - getPts dstFrame >>= setPts pkt - getPts dstFrame >>= setDts pkt + timeStamp <- (+ frameTime) <$> getPts dstFrame + setPts dstFrame timeStamp + setPts pkt timeStamp + -- getPts dstFrame >>= setDts pkt V.unsafeWith pixels $ \ptr -> do setData pkt (castPtr ptr) writePacket diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -14,6 +14,7 @@ import Control.Monad.Error.Class import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Maybe import Data.Foldable (traverse_) import qualified Data.Vector.Storable as V @@ -100,25 +101,38 @@ sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a) -- | Read frames from a video stream. -imageReader :: forall m p e. - (Functor m, MonadIO m, Error e, MonadError e m, - JuicyPixelFormat p) - => FilePath -> m (IO (Maybe (Image p)), IO ()) -imageReader = fmap (first (runMaybeT . aux toJuicyImage)) +imageReaderT :: forall m p. + (Functor m, MonadIO m, MonadError String m, + JuicyPixelFormat p) + => FilePath -> m (IO (Maybe (Image p)), IO ()) +imageReaderT = fmap (first (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 + => FilePath -> IO (IO (Maybe (Image p)), IO ()) +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. -imageReaderTime :: forall m p e. - (Functor m, MonadIO m, Error e, MonadError e m, - JuicyPixelFormat p) - => FilePath -> m (IO (Maybe (Image p, Double)), IO ()) -imageReaderTime = fmap (first (runMaybeT . aux toJuicyImage)) - . frameReaderTime (juicyPixelFormat ([] :: [p])) +imageReaderTimeT :: forall m p. + (Functor m, MonadIO m, MonadError String m, + JuicyPixelFormat p) + => FilePath -> m (IO (Maybe (Image p, Double)), IO ()) +imageReaderTimeT = fmap (first (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 + => FilePath -> IO (IO (Maybe (Image p, Double)), IO ()) +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