ffmpeg-light 0.11.3 → 0.12.0
raw patch · 5 files changed
+520/−32 lines, 5 filesdep +bytestringdep +monad-loopsdep +sdl2dep ~basedep ~mtldep ~transformersnew-component:exe:vplay
Dependencies added: bytestring, monad-loops, sdl2, text
Dependency ranges changed: base, mtl, transformers
Files
- CHANGELOG.md +7/−0
- demo/VPlay.hs +316/−0
- ffmpeg-light.cabal +21/−3
- src/Codec/FFmpeg/Common.hsc +129/−0
- src/Codec/FFmpeg/Juicy.hs +47/−29
CHANGELOG.md view
@@ -1,3 +1,10 @@+# 0.12.0++* Refactoring to better interoperate with SDL2+* SDL2 video player demo executable++[Thanks to Vladimir Pankov!]+ # 0.11.1 * Use `Control.Monad.Except` instead of the deprecated `Control.Monad.Error` (Issue reported by Alexander / @AleXoundOS)
+ demo/VPlay.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Codec.FFmpeg+import Codec.FFmpeg.Common+import Codec.FFmpeg.Decode hiding (av_malloc)++import Control.Concurrent.MVar (newMVar, takeMVar, putMVar)+import Control.Monad.Except+import Control.Monad.Loops+import Control.Monad.Trans.Maybe++import Data.ByteString (ByteString)+import Data.ByteString.Unsafe (unsafePackCStringFinalizer)+import Data.Text (Text)++import Foreign.C.Types+import Foreign.Ptr++import System.Environment++import qualified SDL as SDL+++{- Auxiliary. -}++-- Prepare input source: open, check for streams.+prepareInput :: (MonadIO m, MonadError String m)+ => InputSource+ -> m AVFormatContext+prepareInput inp =+ openInput inp >>= \ ctx -> checkStreams ctx >> return ctx++-- Prepare video codec: find video stream, open.+prepareVideoCodec :: (MonadIO m, MonadError String m)+ => AVFormatContext+ -> m ( CInt+ , AVCodecContext+ , AVCodec+ , AVStream+ , AVDictionary )+prepareVideoCodec inpCtx = do+ (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inpCtx+ dict <- openCodec ctx cod+ return (vidStreamIndex, ctx, cod, vidStream, dict)++-- Transform reader to return timestamp too. +readTS :: (HasPts f, Fractional t)+ => AVRational+ -> IO (Maybe f)+ -> IO (Maybe (f, t))+readTS (AVRational num den) reader =+ -- It's part of frameReaderTime definition.+ let (numl, dend) = (fromIntegral num, fromIntegral den)+ frameTime' frame =+ do n <- getPts frame+ return $ fromIntegral (n * numl) / dend+ reader' = do frame <- reader+ case frame of+ Nothing -> return Nothing+ Just f -> do t <- frameTime' f+ return $ Just (f, t) in reader'+ +-- Transform frame and timestamp reader to compute frame+-- time as a difference between adjacent timestamps. +readTSDiff :: (MonadIO m, MonadIO m', Num t)+ => m' (Maybe (f, t)) -> m (m' (Maybe (f, t)))+readTSDiff readerTS = do+ timeVar <- liftIO $ newMVar 0+ let reader = runMaybeT $ do+ (f, currTime) <- MaybeT readerTS+ prevTime <- takeTime+ putTime currTime+ let timeDiff = currTime - prevTime+ return (f, timeDiff)+ where+ takeTime = liftIO . takeMVar $ timeVar+ putTime = liftIO . putMVar timeVar+ return reader++-- Transformer version of updateTextureByFrame.+updateTextureByFrameT :: SDL.Texture -> AVFrame -> MaybeT IO SDL.Texture+updateTextureByFrameT texture frame =+ copyImageDataT frame >>= updateTexture texture+ where+ updateTexture t img =+ frameLineSizeT frame >>=+ SDL.updateTexture t Nothing img + +-- Update texture by image data from frame.+updateTextureByFrame :: SDL.Texture -> AVFrame -> IO (Maybe SDL.Texture)+updateTextureByFrame t = runMaybeT . updateTextureByFrameT t++-- Return Nothing when condition holds.+nothingWhen+ :: Monad m+ => m a -> (a -> Bool) -> m (Maybe b) -> m (Maybe b)+nothingWhen g p action = do+ -- Generate conditional.+ a <- g+ -- Check predicate.+ if p a+ then return Nothing+ else action+ +-- Retrun Nothing when QuitEvent is received.+nothingOnQuit+ :: MonadIO m+ => m (Maybe a) -> m (Maybe a)+nothingOnQuit action =+ nothingWhen+ SDL.pollEvents+ (not . null . filter+ (\ event ->+ case SDL.eventPayload event of + SDL.QuitEvent -> True+ _ -> False)) action+ +{- Return ByteString filled by image data from frame.+ + Returned ByteString doesn't refer back to it's+ source AVFrame. So, source frame may be deleted+ or changed, but image will stay. + +-}+copyImageData :: AVFrame -> IO (Maybe ByteString)+copyImageData frame =+ runMaybeT $ do+ + -- Get required size of buffer to hold image data.+ imageBufSize <- frameBufferSizeT frame+ + -- Allocate buffer to hold image data.+ imageBuf <- MaybeT $+ Just <$> (av_malloc $ fromIntegral imageBufSize)+ + -- Image data buffer cleanup.+ let imageBufCleanup = av_free imageBuf+ + -- Copy image to buffer.+ _ <- frameCopyToBufferT frame (castPtr imageBuf)+ + -- Fill up byte-string by data from buffer.+ MaybeT $ Just <$>+ unsafePackCStringFinalizer+ (castPtr imageBuf)+ (fromIntegral imageBufSize)+ -- Cleanup for buffer.+ imageBufCleanup++-- Transformer version of copyImageData. +copyImageDataT :: AVFrame -> MaybeT IO ByteString+copyImageDataT = MaybeT . copyImageData+ +-- Convert floating point second to millisecond.+sec2msec :: (RealFrac a, Integral b) => a -> b+sec2msec = floor . (*1000)++-- Adjust window size by display size.+-- It uses first display retrieved from call to SDL.getDisplays.+-- I don't know yet how to get a display where window is opened.+-- So this function won't be used right now.+adjustWindowSize :: MonadIO m => SDL.Window -> m ()+adjustWindowSize w = do+ (SDL.V2 ww wh) <- SDL.get (SDL.windowSize w)+ (SDL.V2 dw dh) <- SDL.displayBoundsSize <$> firstDisplay+ let w' = min ww dw+ h' = min wh dh+ (SDL.windowSize w) SDL.$= (SDL.V2 w' h')+ where+ firstDisplay = SDL.getDisplays >>= return . head+++{- Main. -} + +-- Configuration for video player.+data Config =+ Config+ { cfgWindowTitle :: Text+ , cfgRendererDriver :: CInt+ , cfgFmtFFmpeg :: AVPixelFormat+ , cfgFmtSDL :: SDL.PixelFormat+ }+ +videoPlayer+ :: (MonadIO m, MonadError String m)+ => Config -> InputSource -> m ()+videoPlayer cfg src = do+ + {- Setup. -}+ + liftIO initFFmpeg+ SDL.initializeAll+ + (renderTexture, getTexture, cleanup) <- textureReader src + + liftIO $ whileJust_ (nothingOnQuit getTexture) $+ \ (next, time) -> do+ + {- Rendering. -}+ + -- Rendering start time.+ rStartTime <- SDL.time+ + renderTexture next+ + -- Finish time of rendering.+ rFinishTime <- SDL.time+ + {- Synchronizing. -}+ + -- Total rendering time.+ let rTotalTime = sec2msec $ rFinishTime - rStartTime+ -- Frame time in MS.+ frameTime = sec2msec time+ + -- If rendering time is less then frame time.+ when ( time > 0 && rTotalTime < frameTime) $ do+ -- Sleep their difference.+ SDL.delay $ frameTime - rTotalTime+ + {- Cleanup. -}+ + liftIO cleanup+ SDL.quit+ + where+ + -- Create window using title from config.+ createWindow w h = do+ window <- SDL.createWindow (cfgWindowTitle cfg) SDL.defaultWindow+ (SDL.$=) (SDL.windowSize window) (SDL.V2 w h)+ return window+ + -- Create renderer using driver from config.+ createRenderer window =+ SDL.createRenderer window (cfgRendererDriver cfg) SDL.defaultRenderer++ -- Create texture using pixel format from config.+ createTexture renderer w h =+ SDL.createTexture+ renderer+ (cfgFmtSDL cfg)+ SDL.TextureAccessStreaming+ (SDL.V2 w h)+ + -- Return texture reader, renderer and cleanup.+ textureReader :: (MonadIO m', MonadError String m', MonadIO m)+ => InputSource+ -> m' ( SDL.Texture -> m ()+ , IO (Maybe (SDL.Texture, Double))+ , IO ())+ textureReader inp = do+ + -- Open video.+ inputContext <- prepareInput inp+ (vsIdx, ctx, _, vs, _) <- prepareVideoCodec inputContext+ + -- Get frame size.+ w <- liftIO $ getWidth ctx+ h <- liftIO $ getHeight ctx + + -- Create window, renderer and texture.+ window <- createWindow w h+ renderer <- createRenderer window+ texture <- createTexture renderer w h++ -- Create frame reader.+ let dstFmt = cfgFmtFFmpeg cfg+ (reader, cleanup) <- prepareReader inputContext vsIdx dstFmt ctx+ + -- Transform reader to read frame time.+ timeBase <- liftIO $ getTimeBase vs+ tsDiffReader <- readTSDiff (readTS timeBase reader)+ + -- Texture reader.+ let reader' = runMaybeT $ do+ (f, t) <- MaybeT tsDiffReader+ updateTextureByFrameT texture f+ >>= return . flip (,) t+ + -- Texture renderer.+ render t = do+ SDL.copy renderer t Nothing Nothing+ SDL.present renderer+ + -- New cleanup.+ cleanup' = cleanup+ >> SDL.destroyTexture texture+ >> SDL.destroyRenderer renderer+ >> SDL.destroyWindow window+ + return (render, reader', cleanup')+ ++{- Main. -}++-- Default configuration.+defaultConfig :: Config+defaultConfig =+ Config+ { cfgWindowTitle = "VPLay"+ , cfgRendererDriver = (-1) -- find driver automatically.+ , cfgFmtFFmpeg = avPixFmtRgb24+ , cfgFmtSDL = SDL.RGB24+ }+ +-- Runs videoPlayer in Either monad.+runVideoPlayer :: Config -> FilePath -> IO (Either String ())+runVideoPlayer cfg = runExceptT . videoPlayer cfg . File++-- Video player with default configuration.+-- Command line argument: path to video file.+main :: IO ()+main = getArgs >>= runVideoPlayer defaultConfig . head >> return ()
ffmpeg-light.cabal view
@@ -1,5 +1,5 @@ name: ffmpeg-light-version: 0.11.3+version: 0.12.0 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to@@ -15,7 +15,7 @@ > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" > (fmap ImageRGB8 <$> getFrame) <* cleanup .- Tested with FFmpeg 3.1+ Tested with FFmpeg 3.1 - 3.2.4 license: BSD3 license-file: LICENSE@@ -43,6 +43,11 @@ default: False manual: True +flag BuildVPlayDemo+ description: Build video player demo executable+ default: False+ manual: True+ library exposed-modules: Codec.FFmpeg, Codec.FFmpeg.Common,@@ -62,7 +67,9 @@ vector >= 0.10.9 && < 0.13, transformers >= 0.4.1 && < 0.6, mtl >= 2.2.1 && < 2.3,- JuicyPixels >= 3.1 && < 3.3+ JuicyPixels >= 3.1 && < 3.3,+ bytestring+ pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice hs-source-dirs: src include-dirs: src@@ -89,4 +96,15 @@ hs-source-dirs: demo main-is: Raster.hs default-language: Haskell2010+ ghc-options: -Wall -O2++executable vplay+ if !flag(BuildVPlayDemo)+ buildable: False+ build-depends: base < 5, mtl, transformers, text, monad-loops, bytestring+ if flag(BuildVPlayDemo)+ build-depends: ffmpeg-light, sdl2+ hs-source-dirs: demo+ main-is: VPlay.hs+ default-language: Haskell2010 ghc-options: -Wall -O2
src/Codec/FFmpeg/Common.hsc view
@@ -7,6 +7,7 @@ import Control.Monad.IO.Class import Foreign.C.Types import Foreign.Ptr+import Control.Monad.Trans.Maybe foreign import ccall "avcodec_open2" open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt@@ -47,6 +48,43 @@ -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt +-- Return size of buffer for image.+foreign import ccall "av_image_get_buffer_size"+ av_image_get_buffer_size+ -- Pixel format.+ :: AVPixelFormat+ -- Width.+ -> CInt+ -- Height.+ -> CInt+ -- Line size alignment.+ -> CInt+ -- Size of buffer.+ -> IO CInt+ +-- Copy image to buffer.+foreign import ccall "av_image_copy_to_buffer"+ av_image_copy_to_buffer+ -- Destination buffer.+ :: Ptr CUChar+ -- Destination buffer size.+ -> CInt+ -- Source image data.+ -> Ptr (Ptr CUChar)+ -- Source image line size.+ -> Ptr CInt+ -- Source image pixel format.+ -> AVPixelFormat+ -- Source image width.+ -> CInt+ -- Source image height.+ -> CInt+ -- Source image line size alignment.+ -> CInt+ -- Number of bytes written to destination.+ -> IO CInt+ + -- * Utility functions -- | Catch an IOException from an IO action and re-throw it in a@@ -83,3 +121,94 @@ | fmt == avPixFmtRgb8 = Just 1 | fmt == avPixFmtPal8 = Just 1 | otherwise = Nothing+ +-- | Return line size alignment.+lineSizeAlign :: CInt -> CInt+lineSizeAlign lineSize+ -- Alignment for 512 bit register.+ | lineSize `mod` 64 == 0 = 64+ -- Alignment for 256 bit register.+ | lineSize `mod` 32 == 0 = 32+ -- Alignment for 128 bit register.+ | lineSize `mod` 16 == 0 = 16+ -- Alignment for 64 bit register.+ | lineSize `mod` 8 == 0 = 8+ -- Alignment for 32 bit register.+ | lineSize `mod` 4 == 0 = 4+ -- Alignment for 16 bit register.+ | lineSize `mod` 2 == 0 = 2+ -- Alignment for 8 bit register.+ | otherwise = 1++-- | Retun 'AVFrame's line size.+frameLineSize :: AVFrame -> IO (Maybe CInt)+frameLineSize frame = do+ w <- getWidth frame+ fmt <- getPixelFormat frame + return $+ (*w) . fromIntegral <$> avPixelStride fmt++-- | Transformer version of 'frameLineSize'.+frameLineSizeT :: AVFrame -> MaybeT IO CInt+frameLineSizeT = MaybeT . frameLineSize ++-- Return 'AVFrame's alignment.+frameAlign :: AVFrame -> IO (Maybe CInt)+frameAlign = fmap (fmap lineSizeAlign) . frameLineSize ++-- Transformer version of 'frameAlign'.+frameAlignT :: AVFrame -> MaybeT IO CInt+frameAlignT = MaybeT . frameAlign+++-- * Wrappers for copying 'AVFrame's image to buffer. + +-- | Return size of buffer for 'AVFrame's image.+frameBufferSize :: AVFrame -> IO (Maybe CInt)+frameBufferSize frame =+ runMaybeT $ do+ a <- frameAlignT frame+ MaybeT $ do+ fmt <- getPixelFormat frame+ w <- getWidth frame+ h <- getHeight frame+ Just <$> av_image_get_buffer_size fmt w h a++-- | Transformer version of 'frameBufferSize'.+frameBufferSizeT :: AVFrame -> MaybeT IO CInt+frameBufferSizeT = MaybeT . frameBufferSize++-- | Copy 'AVFrame's image to buffer. +-- It is assumed that size of buffer is equal to+--+-- > bufSize <- fromJust <$> frameBufferSize frame.+frameCopyToBuffer :: AVFrame -> Ptr CUChar -> IO (Maybe CInt)+frameCopyToBuffer frame buffer =+ runMaybeT $ do+ + a <- frameAlignT frame+ s <- frameBufferSizeT frame+ + MaybeT $ do+ + let imageData = hasData frame+ lineSize = hasLineSize frame+ + fmt <- getPixelFormat frame+ w <- getWidth frame+ h <- getHeight frame++ Just <$>+ av_image_copy_to_buffer+ buffer+ s+ (castPtr imageData)+ lineSize+ fmt+ w+ h+ a+ +-- | Transformer version of 'frameCopyToBuffer'.+frameCopyToBufferT :: AVFrame -> Ptr CUChar -> MaybeT IO CInt+frameCopyToBufferT frame = MaybeT . frameCopyToBuffer frame
src/Codec/FFmpeg/Juicy.hs view
@@ -22,7 +22,30 @@ import Foreign.Marshal.Array (advancePtr, copyArray) import Foreign.Ptr (castPtr, Ptr) import Foreign.Storable (sizeOf)+import Data.Maybe (maybe) ++-- | 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++ 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. --@@ -30,56 +53,51 @@ toJuicyT :: AVFrame -> MaybeT IO DynamicImage toJuicyT = MaybeT . toJuicy + -- | Convert an 'AVFrame' to a 'DynamicImage'. toJuicy :: AVFrame -> IO (Maybe DynamicImage) toJuicy frame = runMaybeT $ do- fmt <- lift $ getPixelFormat frame- pixelStride <- MaybeT . return $ avPixelStride fmt++ v <- frameToVectorT frame+ MaybeT $ do+ w <- fromIntegral <$> getWidth frame h <- fromIntegral <$> getHeight frame- pixels <- castPtr <$> getData frame :: IO (Ptr CUChar)- srcStride <- fromIntegral <$> getLineSize frame- let dstStride = w * pixelStride- v <- VM.new $ h * dstStride- VM.unsafeWith v $ \vptr ->- mapM_ (\(i,o) -> copyArray (advancePtr vptr o)- (advancePtr pixels i)- dstStride)- (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1])- v' <- V.unsafeFreeze v+ let mkImage :: V.Storable (PixelBaseComponent a) => (Image a -> DynamicImage) -> Maybe DynamicImage- mkImage c = Just $ c (Image w h (V.unsafeCast v'))+ 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 + -- | Convert an 'AVFrame' to an 'Image'. toJuicyImage :: forall p. JuicyPixelFormat p => AVFrame -> IO (Maybe (Image p))-toJuicyImage frame =- do fmt <- getPixelFormat frame- if fmt /= juicyPixelFormat ([] :: [p])- then return Nothing- else do w <- fromIntegral <$> getWidth frame- h <- fromIntegral <$> getHeight frame- pixels <- castPtr <$> getData frame :: IO (Ptr CUChar)- srcStride <- fromIntegral <$> getLineSize frame- let dstStride = w * juicyPixelStride ([]::[p])- v <- VM.new $ h * dstStride- VM.unsafeWith v $ \vptr ->- mapM_ (\(i,o) -> copyArray (advancePtr vptr o)- (advancePtr pixels i)- dstStride)- (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1])- Just . Image w h . V.unsafeCast <$> V.unsafeFreeze v+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