<|start_filename|>src/Codec/FFmpeg/Enums.hsc<|end_filename|>
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Codec.FFmpeg.Enums where
import Data.Bits (Bits)
import Foreign.C.Types
import Foreign.Storable (Storable)

#include <libavcodec/avcodec.h>
#include <libavformat/avformat.h>
#include <libavutil/avutil.h>
#include <libavutil/pixfmt.h>
#include <libavutil/mathematics.h>
#include <libswscale/swscale.h>
#include <libswresample/swresample.h>
#include "nameCompat.h"

newtype AVMediaType = AVMediaType CInt deriving (Eq, Storable)
#enum AVMediaType,AVMediaType \
 , AVMEDIA_TYPE_VIDEO\
 , AVMEDIA_TYPE_AUDIO\
 , AVMEDIA_TYPE_DATA\
 , AVMEDIA_TYPE_SUBTITLE\
 , AVMEDIA_TYPE_ATTACHMENT\
 , AVMEDIA_TYPE_NB

newtype AVPixelFormat = AVPixelFormat CInt deriving (Eq, Storable)
#enum AVPixelFormat,AVPixelFormat \
 , AV_PIX_FMT_NONE\
 , AV_PIX_FMT_RGB24\
 , AV_PIX_FMT_RGBA\
 , AV_PIX_FMT_BGRA\
 , AV_PIX_FMT_Y400A\
 , AV_PIX_FMT_RGB32\
 , AV_PIX_FMT_RGB32_1\
 , AV_PIX_FMT_BGR32\
 , AV_PIX_FMT_BGR32_1\
 , AV_PIX_FMT_RGB8\
 , AV_PIX_FMT_BGR8\
 , AV_PIX_FMT_RGB4_BYTE\
 , AV_PIX_FMT_BGR4_BYTE\
 , AV_PIX_FMT_GRAY8\
 , AV_PIX_FMT_GRAY16\
 , AV_PIX_FMT_GRAY8A\
 , AV_PIX_FMT_PAL8\
 , AV_PIX_FMT_RGB565\
 , AV_PIX_FMT_RGB555\
 , AV_PIX_FMT_YUV420P\
 , AV_PIX_FMT_YUV420P9\
 , AV_PIX_FMT_YUV420P10\
 , AV_PIX_FMT_YUV420P12\
 , AV_PIX_FMT_YUV422P12\
 , AV_PIX_FMT_YUV444P12\
 , AV_PIX_FMT_YUV420P14\
 , AV_PIX_FMT_YUV422P14\
 , AV_PIX_FMT_YUV444P14\
 , AV_PIX_FMT_YUV420P16\
 , AV_PIX_FMT_YUV422P16\
 , AV_PIX_FMT_YUV444P16\
 , AV_PIX_FMT_RGBA64\
 , AV_PIX_FMT_BGRA64

instance Show AVPixelFormat where
  show x
    | x == avPixFmtRgb24 = "AV_PIX_FMT_RGB24"
    | x == avPixFmtYuv420p = "AV_PIX_FMT_Y420P"
    | x == avPixFmtYuv422p12 = "AV_PIX_FMTYUV422P12"
    | x == avPixFmtYuv420p14 = "AV_PIX_FMTYUV422P12"
    | otherwise = let AVPixelFormat y = x
                  in "Other pixel format: "++show y

newtype AVCodecID = AVCodecID CInt deriving (Eq, Show, Storable)
#enum AVCodecID,AVCodecID \
 , AV_CODEC_ID_NONE\
 , AV_CODEC_ID_MPEG1VIDEO\
 , AV_CODEC_ID_MPEG2VIDEO\
 , AV_CODEC_ID_H261\
 , AV_CODEC_ID_H263\
 , AV_CODEC_ID_RV10\
 , AV_CODEC_ID_RV20\
 , AV_CODEC_ID_MJPEG\
 , AV_CODEC_ID_MJPEGB\
 , AV_CODEC_ID_LJPEG\
 , AV_CODEC_ID_SP5X\
 , AV_CODEC_ID_JPEGLS\
 , AV_CODEC_ID_MPEG4\
 , AV_CODEC_ID_RAWVIDEO\
 , AV_CODEC_ID_MSMPEG4V1\
 , AV_CODEC_ID_MSMPEG4V2\
 , AV_CODEC_ID_MSMPEG4V3\
 , AV_CODEC_ID_WMV1\
 , AV_CODEC_ID_WMV2\
 , AV_CODEC_ID_H263P\
 , AV_CODEC_ID_H263I\
 , AV_CODEC_ID_FLV1\
 , AV_CODEC_ID_SVQ1\
 , AV_CODEC_ID_SVQ3\
 , AV_CODEC_ID_DVVIDEO\
 , AV_CODEC_ID_HUFFYUV\
 , AV_CODEC_ID_CYUV\
 , AV_CODEC_ID_H264\
 , AV_CODEC_ID_INDEO3\
 , AV_CODEC_ID_VP3\
 , AV_CODEC_ID_THEORA\
 , AV_CODEC_ID_ASV1\
 , AV_CODEC_ID_ASV2\
 , AV_CODEC_ID_FFV1\
 , AV_CODEC_ID_4XM\
 , AV_CODEC_ID_VCR1\
 , AV_CODEC_ID_CLJR\
 , AV_CODEC_ID_MDEC\
 , AV_CODEC_ID_ROQ\
 , AV_CODEC_ID_INTERPLAY_VIDEO\
 , AV_CODEC_ID_XAN_WC3\
 , AV_CODEC_ID_XAN_WC4\
 , AV_CODEC_ID_RPZA\
 , AV_CODEC_ID_CINEPAK\
 , AV_CODEC_ID_WS_VQA\
 , AV_CODEC_ID_MSRLE\
 , AV_CODEC_ID_MSVIDEO1\
 , AV_CODEC_ID_IDCIN\
 , AV_CODEC_ID_8BPS\
 , AV_CODEC_ID_SMC\
 , AV_CODEC_ID_FLIC\
 , AV_CODEC_ID_TRUEMOTION1\
 , AV_CODEC_ID_VMDVIDEO\
 , AV_CODEC_ID_MSZH\
 , AV_CODEC_ID_ZLIB\
 , AV_CODEC_ID_QTRLE\
 , AV_CODEC_ID_TSCC\
 , AV_CODEC_ID_ULTI\
 , AV_CODEC_ID_QDRAW\
 , AV_CODEC_ID_VIXL\
 , AV_CODEC_ID_QPEG\
 , AV_CODEC_ID_PNG\
 , AV_CODEC_ID_PPM\
 , AV_CODEC_ID_PBM\
 , AV_CODEC_ID_PGM\
 , AV_CODEC_ID_PGMYUV\
 , AV_CODEC_ID_PAM\
 , AV_CODEC_ID_FFVHUFF\
 , AV_CODEC_ID_RV30\
 , AV_CODEC_ID_RV40\
 , AV_CODEC_ID_VC1\
 , AV_CODEC_ID_WMV3\
 , AV_CODEC_ID_LOCO\
 , AV_CODEC_ID_WNV1\
 , AV_CODEC_ID_AASC\
 , AV_CODEC_ID_INDEO2\
 , AV_CODEC_ID_FRAPS\
 , AV_CODEC_ID_TRUEMOTION2\
 , AV_CODEC_ID_BMP\
 , AV_CODEC_ID_CSCD\
 , AV_CODEC_ID_MMVIDEO\
 , AV_CODEC_ID_ZMBV\
 , AV_CODEC_ID_AVS\
 , AV_CODEC_ID_SMACKVIDEO\
 , AV_CODEC_ID_NUV\
 , AV_CODEC_ID_KMVC\
 , AV_CODEC_ID_FLASHSV\
 , AV_CODEC_ID_CAVS\
 , AV_CODEC_ID_JPEG2000\
 , AV_CODEC_ID_VMNC\
 , AV_CODEC_ID_VP5\
 , AV_CODEC_ID_VP6\
 , AV_CODEC_ID_VP6F\
 , AV_CODEC_ID_TARGA\
 , AV_CODEC_ID_DSICINVIDEO\
 , AV_CODEC_ID_TIERTEXSEQVIDEO\
 , AV_CODEC_ID_TIFF\
 , AV_CODEC_ID_GIF\
 , AV_CODEC_ID_DXA\
 , AV_CODEC_ID_DNXHD\
 , AV_CODEC_ID_THP\
 , AV_CODEC_ID_SGI\
 , AV_CODEC_ID_C93\
 , AV_CODEC_ID_BETHSOFTVID\
 , AV_CODEC_ID_PTX\
 , AV_CODEC_ID_TXD\
 , AV_CODEC_ID_VP6A\
 , AV_CODEC_ID_AMV\
 , AV_CODEC_ID_VB\
 , AV_CODEC_ID_PCX\
 , AV_CODEC_ID_SUNRAST\
 , AV_CODEC_ID_INDEO4\
 , AV_CODEC_ID_INDEO5\
 , AV_CODEC_ID_MIMIC\
 , AV_CODEC_ID_RL2\
 , AV_CODEC_ID_ESCAPE124\
 , AV_CODEC_ID_DIRAC\
 , AV_CODEC_ID_BFI\
 , AV_CODEC_ID_CMV\
 , AV_CODEC_ID_MOTIONPIXELS\
 , AV_CODEC_ID_TGV\
 , AV_CODEC_ID_TGQ\
 , AV_CODEC_ID_TQI\
 , AV_CODEC_ID_AURA\
 , AV_CODEC_ID_AURA2\
 , AV_CODEC_ID_V210X\
 , AV_CODEC_ID_TMV\
 , AV_CODEC_ID_V210\
 , AV_CODEC_ID_DPX\
 , AV_CODEC_ID_MAD\
 , AV_CODEC_ID_FRWU\
 , AV_CODEC_ID_FLASHSV2\
 , AV_CODEC_ID_CDGRAPHICS\
 , AV_CODEC_ID_R210\
 , AV_CODEC_ID_ANM\
 , AV_CODEC_ID_BINKVIDEO\
 , AV_CODEC_ID_IFF_ILBM\
 , AV_CODEC_ID_KGV1\
 , AV_CODEC_ID_YOP\
 , AV_CODEC_ID_VP8\
 , AV_CODEC_ID_PICTOR\
 , AV_CODEC_ID_ANSI\
 , AV_CODEC_ID_A64_MULTI\
 , AV_CODEC_ID_A64_MULTI5\
 , AV_CODEC_ID_R10K\
 , AV_CODEC_ID_MXPEG\
 , AV_CODEC_ID_LAGARITH\
 , AV_CODEC_ID_PRORES\
 , AV_CODEC_ID_JV\
 , AV_CODEC_ID_DFA\
 , AV_CODEC_ID_WMV3IMAGE\
 , AV_CODEC_ID_VC1IMAGE\
 , AV_CODEC_ID_UTVIDEO\
 , AV_CODEC_ID_BMV_VIDEO\
 , AV_CODEC_ID_VBLE\
 , AV_CODEC_ID_DXTORY\
 , AV_CODEC_ID_V410\
 , AV_CODEC_ID_XWD\
 , AV_CODEC_ID_CDXL\
 , AV_CODEC_ID_XBM\
 , AV_CODEC_ID_ZEROCODEC\
 , AV_CODEC_ID_MSS1\
 , AV_CODEC_ID_MSA1\
 , AV_CODEC_ID_TSCC2\
 , AV_CODEC_ID_MTS2\
 , AV_CODEC_ID_CLLC\
 , AV_CODEC_ID_MSS2\
 , AV_CODEC_ID_VP9\
 , AV_CODEC_ID_AIC\
 , AV_CODEC_ID_ESCAPE130\
 , AV_CODEC_ID_G2M\
 , AV_CODEC_ID_WEBP\
 , AV_CODEC_ID_HNM4_VIDEO\
 , AV_CODEC_ID_HEVC\
 , AV_CODEC_ID_MP2\
 , AV_CODEC_ID_MP3\
 , AV_CODEC_ID_AAC\
 , AV_CODEC_ID_AC3\
 , AV_CODEC_ID_DTS\
 , AV_CODEC_ID_VORBIS\
 , AV_CODEC_ID_DVAUDIO\
 , AV_CODEC_ID_WMAV1\
 , AV_CODEC_ID_WMAV2\
 , AV_CODEC_ID_MACE3\
 , AV_CODEC_ID_MACE6\
 , AV_CODEC_ID_VMDAUDIO\
 , AV_CODEC_ID_FLAC\
 , AV_CODEC_ID_MP3ADU\
 , AV_CODEC_ID_MP3ON4\
 , AV_CODEC_ID_SHORTEN\
 , AV_CODEC_ID_ALAC\
 , AV_CODEC_ID_WESTWOOD_SND1\
 , AV_CODEC_ID_GSM\
 , AV_CODEC_ID_QDM2\
 , AV_CODEC_ID_COOK\
 , AV_CODEC_ID_TRUESPEECH\
 , AV_CODEC_ID_TTA\
 , AV_CODEC_ID_SMACKAUDIO\
 , AV_CODEC_ID_QCELP\
 , AV_CODEC_ID_WAVPACK\
 , AV_CODEC_ID_DSICINAUDIO\
 , AV_CODEC_ID_IMC\
 , AV_CODEC_ID_MUSEPACK7\
 , AV_CODEC_ID_MLP\
 , AV_CODEC_ID_GSM_MS\
 , AV_CODEC_ID_ATRAC3\
 , AV_CODEC_ID_APE\
 , AV_CODEC_ID_NELLYMOSER\
 , AV_CODEC_ID_MUSEPACK8\
 , AV_CODEC_ID_SPEEX\
 , AV_CODEC_ID_WMAVOICE\
 , AV_CODEC_ID_WMAPRO\
 , AV_CODEC_ID_WMALOSSLESS\
 , AV_CODEC_ID_ATRAC3P\
 , AV_CODEC_ID_EAC3\
 , AV_CODEC_ID_SIPR\
 , AV_CODEC_ID_MP1\
 , AV_CODEC_ID_TWINVQ\
 , AV_CODEC_ID_TRUEHD\
 , AV_CODEC_ID_MP4ALS\
 , AV_CODEC_ID_ATRAC1\
 , AV_CODEC_ID_BINKAUDIO_RDFT\
 , AV_CODEC_ID_BINKAUDIO_DCT\
 , AV_CODEC_ID_AAC_LATM\
 , AV_CODEC_ID_QDMC\
 , AV_CODEC_ID_CELT\
 , AV_CODEC_ID_G723_1\
 , AV_CODEC_ID_G729\
 , AV_CODEC_ID_8SVX_EXP\
 , AV_CODEC_ID_8SVX_FIB\
 , AV_CODEC_ID_BMV_AUDIO\
 , AV_CODEC_ID_RALF\
 , AV_CODEC_ID_IAC\
 , AV_CODEC_ID_ILBC\
 , AV_CODEC_ID_OPUS\
 , AV_CODEC_ID_COMFORT_NOISE\
 , AV_CODEC_ID_TAK\
 , AV_CODEC_ID_METASOUND\
 , AV_CODEC_ID_PAF_AUDIO\
 , AV_CODEC_ID_ON2AVC\
 , AV_CODEC_ID_DSS_SP\
 , AV_CODEC_ID_FFWAVESYNTH\
 , AV_CODEC_ID_SONIC\
 , AV_CODEC_ID_SONIC_LS\
 , AV_CODEC_ID_EVRC\
 , AV_CODEC_ID_SMV\
 , AV_CODEC_ID_DSD_LSBF\
 , AV_CODEC_ID_DSD_MSBF\
 , AV_CODEC_ID_DSD_LSBF_PLANAR\
 , AV_CODEC_ID_DSD_MSBF_PLANAR\
 , AV_CODEC_ID_4GV\
 , AV_CODEC_ID_INTERPLAY_ACM\
 , AV_CODEC_ID_XMA1\
 , AV_CODEC_ID_XMA2\
 , AV_CODEC_ID_DST


newtype SwsAlgorithm = SwsAlgorithm CUInt deriving (Eq, Show, Storable)
#enum SwsAlgorithm,SwsAlgorithm \
 , SWS_FAST_BILINEAR\
 , SWS_BILINEAR\
 , SWS_BICUBIC\
 , SWS_X\
 , SWS_POINT\
 , SWS_AREA\
 , SWS_BICUBLIN\
 , SWS_GAUSS\
 , SWS_SINC\
 , SWS_LANCZOS\
 , SWS_SPLINE

newtype FFProfile = FFProfile CInt deriving (Eq, Storable)
#enum FFProfile, FFProfile \
 , FF_PROFILE_AAC_MAIN\
 , FF_PROFILE_AAC_LOW\
 , FF_PROFILE_AAC_SSR\
 , FF_PROFILE_AAC_LTP\
 , FF_PROFILE_AAC_HE\
 , FF_PROFILE_AAC_HE_V2\
 , FF_PROFILE_AAC_LD\
 , FF_PROFILE_AAC_ELD\
 , FF_PROFILE_MPEG2_AAC_LOW\
 , FF_PROFILE_MPEG2_AAC_HE\
 , FF_PROFILE_DTS\
 , FF_PROFILE_DTS_ES\
 , FF_PROFILE_DTS_96_24\
 , FF_PROFILE_DTS_HD_HRA\
 , FF_PROFILE_DTS_HD_MA\
 , FF_PROFILE_MPEG2_422\
 , FF_PROFILE_MPEG2_HIGH\
 , FF_PROFILE_MPEG2_SS\
 , FF_PROFILE_MPEG2_SNR_SCALABLE\
 , FF_PROFILE_MPEG2_MAIN\
 , FF_PROFILE_MPEG2_SIMPLE\
 , FF_PROFILE_H264_CONSTRAINED\
 , FF_PROFILE_H264_INTRA\
 , FF_PROFILE_H264_BASELINE\
 , FF_PROFILE_H264_CONSTRAINED_BASELINE\
 , FF_PROFILE_H264_MAIN\
 , FF_PROFILE_H264_EXTENDED\
 , FF_PROFILE_H264_HIGH\
 , FF_PROFILE_H264_HIGH_10\
 , FF_PROFILE_H264_HIGH_10_INTRA\
 , FF_PROFILE_H264_HIGH_422\
 , FF_PROFILE_H264_HIGH_422_INTRA\
 , FF_PROFILE_H264_HIGH_444\
 , FF_PROFILE_H264_HIGH_444_PREDICTIVE\
 , FF_PROFILE_H264_HIGH_444_INTRA\
 , FF_PROFILE_H264_CAVLC_444\
 , FF_PROFILE_VC1_SIMPLE\
 , FF_PROFILE_VC1_MAIN\
 , FF_PROFILE_VC1_COMPLEX\
 , FF_PROFILE_VC1_ADVANCED\
 , FF_PROFILE_MPEG4_SIMPLE\
 , FF_PROFILE_MPEG4_SIMPLE_SCALABLE\
 , FF_PROFILE_MPEG4_CORE\
 , FF_PROFILE_MPEG4_MAIN\
 , FF_PROFILE_MPEG4_N_BIT\
 , FF_PROFILE_MPEG4_SCALABLE_TEXTURE\
 , FF_PROFILE_MPEG4_SIMPLE_FACE_ANIMATION\
 , FF_PROFILE_MPEG4_BASIC_ANIMATED_TEXTURE\
 , FF_PROFILE_MPEG4_HYBRID\
 , FF_PROFILE_MPEG4_ADVANCED_REAL_TIME\
 , FF_PROFILE_MPEG4_CORE_SCALABLE\
 , FF_PROFILE_MPEG4_ADVANCED_CODING\
 , FF_PROFILE_MPEG4_ADVANCED_CORE\
 , FF_PROFILE_MPEG4_ADVANCED_SCALABLE_TEXTURE\
 , FF_PROFILE_MPEG4_SIMPLE_STUDIO\
 , FF_PROFILE_MPEG4_ADVANCED_SIMPLE

newtype AVIOFlag = AVIOFlag CInt deriving (Eq, Storable)
#enum AVIOFlag, AVIOFlag \
 , AVIO_FLAG_READ\
 , AVIO_FLAG_WRITE\
 , AVIO_FLAG_READ_WRITE\
 , AVIO_FLAG_NONBLOCK\
 , AVIO_FLAG_DIRECT

newtype AVRoundMode = AVRoundMode CInt deriving (Eq, Storable)
#enum AVRoundMode, AVRoundMode \
 , AV_ROUND_ZERO\
 , AV_ROUND_INF\
 , AV_ROUND_DOWN\
 , AV_ROUND_UP\
 , AV_ROUND_NEAR_INF\
 , AV_ROUND_PASS_MINMAX

newtype CodecFlag = CodecFlag CInt deriving (Eq, Bits, Storable)
#if LIBAVCODEC_VERSION_MAJOR < 57
#enum CodecFlag, CodecFlag \
 , CODEC_FLAG_UNALIGNED\
 , CODEC_FLAG_QSCALE\
 , CODEC_FLAG_4MV\
 , CODEC_FLAG_OUTPUT_CORRUPT\
 , CODEC_FLAG_QPEL\
 , CODEC_FLAG_GMC\
 , CODEC_FLAG_MV0\
 , CODEC_FLAG_INPUT_PRESERVED\
 , CODEC_FLAG_PASS1\
 , CODEC_FLAG_PASS2\
 , CODEC_FLAG_GRAY\
 , CODEC_FLAG_EMU_EDGE\
 , CODEC_FLAG_PSNR\
 , CODEC_FLAG_TRUNCATED\
 , CODEC_FLAG_NORMALIZE_AQP\
 , CODEC_FLAG_INTERLACED_DCT\
 , CODEC_FLAG_LOW_DELAY\
 , CODEC_FLAG_GLOBAL_HEADER\
 , CODEC_FLAG_BITEXACT\
 , CODEC_FLAG_AC_PRED\
 , CODEC_FLAG_LOOP_FILTER\
 , CODEC_FLAG_INTERLACED_ME\
 , CODEC_FLAG_CLOSED_GOP
#else
#enum CodecFlag, CodecFlag \
 , AV_CODEC_FLAG_UNALIGNED\
 , AV_CODEC_FLAG_QSCALE\
 , AV_CODEC_FLAG_4MV\
 , AV_CODEC_FLAG_OUTPUT_CORRUPT\
 , AV_CODEC_FLAG_QPEL\
 , AV_CODEC_FLAG_PASS1\
 , AV_CODEC_FLAG_PASS2\
 , 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\
 , AV_CODEC_FLAG_BITEXACT\
 , AV_CODEC_FLAG_AC_PRED\
 , AV_CODEC_FLAG_INTERLACED_ME\
 , AV_CODEC_FLAG_CLOSED_GOP
#endif

newtype FormatFlag = FormatFlag CInt deriving (Eq, Bits, Storable)
#if LIBAVCODEC_VERSION_MAJOR < 57
#enum FormatFlag, FormatFlag \
 , AVFMT_NOFILE\
 , AVFMT_NEEDNUMBER\
 , AVFMT_RAWPICTURE\
 , AVFMT_GLOBALHEADER\
 , AVFMT_NOTIMESTAMPS\
 , AVFMT_VARIABLE_FPS\
 , AVFMT_NODIMENSIONS\
 , AVFMT_NOSTREAMS\
 , AVFMT_ALLOW_FLUSH\
 , AVFMT_TS_NONSTRICT
#else
#enum FormatFlag, FormatFlag \
 , AVFMT_NOFILE\
 , AVFMT_NEEDNUMBER\
 , AVFMT_GLOBALHEADER\
 , AVFMT_NOTIMESTAMPS\
 , AVFMT_VARIABLE_FPS\
 , AVFMT_NODIMENSIONS\
 , AVFMT_NOSTREAMS\
 , AVFMT_NOBINSEARCH\
 , AVFMT_NOGENSEARCH\
 , AVFMT_NO_BYTE_SEEK\
 , AVFMT_ALLOW_FLUSH\
 , AVFMT_TS_NONSTRICT\
 , AVFMT_TS_NEGATIVE\
 , AVFMT_SEEK_TO_PTS
#endif

newtype PacketFlag = PacketFlag CInt deriving (Eq, Bits, Storable)
#enum PacketFlag, PacketFlag \
 , AV_PKT_FLAG_KEY\
 , AV_PKT_FLAG_CORRUPT

newtype LogLevel = LogLevel CInt deriving (Eq, Bits, Storable)
#enum LogLevel, LogLevel \
 , AV_LOG_QUIET\
 , AV_LOG_PANIC\
 , AV_LOG_FATAL\
 , AV_LOG_ERROR\
 , AV_LOG_WARNING\
 , AV_LOG_INFO\
 , AV_LOG_VERBOSE\
 , AV_LOG_DEBUG\
 , AV_LOG_TRACE\
 , AV_LOG_MAX_OFFSET

newtype AVSampleFormat = AVSampleFormat CInt deriving (Eq, Bits, Storable)
#enum AVSampleFormat, AVSampleFormat \
 , AV_SAMPLE_FMT_NONE\
 , AV_SAMPLE_FMT_U8\
 , AV_SAMPLE_FMT_S16\
 , AV_SAMPLE_FMT_S32\
 , AV_SAMPLE_FMT_FLT\
 , AV_SAMPLE_FMT_DBL\
 , AV_SAMPLE_FMT_U8P\
 , AV_SAMPLE_FMT_S16P\
 , AV_SAMPLE_FMT_S32P\
 , AV_SAMPLE_FMT_FLTP\
 , AV_SAMPLE_FMT_DBLP\
 , AV_SAMPLE_FMT_NB

getSampleFormatInt :: AVSampleFormat -> CInt
getSampleFormatInt (AVSampleFormat i) = i


<|start_filename|>src/Codec/FFmpeg/Juicy.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, 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.Types
import Control.Arrow (first)
import Control.Monad ((>=>))
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import Data.Foldable (traverse_)
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)


-- | 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.
--
-- > toJuicyT = MaybeT . toJuicy
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
        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 = 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
  juicyPixelFormat :: proxy a -> AVPixelFormat

instance JuicyPixelFormat Pixel8 where
  juicyPixelFormat _ = avPixFmtGray8

instance JuicyPixelFormat PixelRGB8 where
  juicyPixelFormat _ = avPixFmtRgb24

instance JuicyPixelFormat PixelRGBA8 where
  juicyPixelFormat _ = avPixFmtRgba

-- | Bytes-per-pixel for a JuicyPixels 'Pixel' type.
juicyPixelStride :: forall a proxy. Pixel a => proxy a -> Int
juicyPixelStride _ =
  sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a)

-- | 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]))
  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

-- | 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]))
  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 ())
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
-- that 'Nothing' /must/ be provided when finishing in order to
-- properly terminate video encoding.
--
-- Support for source images that are of a different size to the
-- output resolution is limited to non-palettized destination formats
-- (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 ep f = do
  videoWriter <- frameWriter ep f
  return $ (. fmap fromJuciy) videoWriter

-- | Util function to convert a JuicyPixels image to the same structure
-- used by 'frameWriter'
fromJuciy :: forall p. JuicyPixelFormat p
          => Image p -> (AVPixelFormat, V2 CInt, V.Vector CUChar)
fromJuciy img = (juicyPixelFormat ([]::[p]), V2 w h, p)
  where
    w = fromIntegral $ imageWidth img
    h = fromIntegral $ imageHeight img
    p = V.unsafeCast $ imageData img


<|start_filename|>src/Codec/FFmpeg/AudioStream.hs<|end_filename|>
module Codec.FFmpeg.AudioStream where

import           Codec.FFmpeg.Enums
import           Data.Bits
import qualified Data.Vector.Storable as V
import           Foreign.C.Types

data AudioStream = AudioStream
  { asBitRate       :: CInt
  , asSampleFormat  :: AVSampleFormat
  , asSampleRate    :: CInt
  , asChannelLayout :: CULong
  , asChannelCount  :: CInt
  , asCodec         :: AVCodecID
  }

-- These are all defined as #defines so I don't think we can FFI them
avChFrontLeft :: CULong
avChFrontLeft = 0x00000001

avChFrontRight :: CULong
avChFrontRight = 0x00000002

avChFrontCenter :: CULong
avChFrontCenter = 0x00000004

avChLowFrequency :: CULong
avChLowFrequency = 0x00000008

avChBackLeft :: CULong
avChBackLeft = 0x00000010

avChBackRight :: CULong
avChBackRight = 0x00000020

avChFrontLeftOfCenter :: CULong
avChFrontLeftOfCenter = 0x00000040

avChFrontRightOfCenter :: CULong
avChFrontRightOfCenter =  0x00000080

avChBackCenter :: CULong
avChBackCenter = 0x00000100

avChSideLeft :: CULong
avChSideLeft = 0x00000200

avChSideRight :: CULong
avChSideRight = 0x00000400

avChTopCenter :: CULong
avChTopCenter = 0x00000800

avChTopFrontLeft :: CULong
avChTopFrontLeft = 0x00001000

avChTopFrontCenter :: CULong
avChTopFrontCenter = 0x00002000

avChTopFrontRight :: CULong
avChTopFrontRight = 0x00004000

avChTopBackLeft :: CULong
avChTopBackLeft = 0x00008000

avChTopBackCenter :: CULong
avChTopBackCenter = 0x00010000

avChTopBackRight :: CULong
avChTopBackRight = 0x00020000

avChStereoLeft :: CULong
avChStereoLeft = 0x20000000

avChStereoRight :: CULong
avChStereoRight = 0x40000000

avChLayoutMono =              avChFrontCenter
avChLayoutStereo =            avChFrontLeft .|. avChFrontRight
avChLayout2point1 =           avChLayoutStereo .|. avChLowFrequency
avChLayout21 =               avChLayoutStereo .|. avChBackCenter
avChLayoutSurround =          avChLayoutStereo .|. avChFrontCenter
avChLayout3point1 =           avChLayoutSurround .|. avChLowFrequency
avChLayout4point0 =           avChLayoutSurround .|. avChBackCenter
avChLayout4point1 =           avChLayout4point0 .|. avChLowFrequency
avChLayout22 =               avChLayoutStereo .|. avChSideLeft .|. avChSideRight
avChLayoutQuad =              avChLayoutStereo .|. avChBackLeft .|. avChBackRight
avChLayout5point0 =           avChLayoutSurround .|. avChSideLeft .|. avChSideRight
avChLayout5point1 =           avChLayout5point0 .|. avChLowFrequency
avChLayout5point0Back =      avChLayoutSurround .|. avChBackLeft .|. avChBackRight
avChLayout5point1Back =      avChLayout5point0Back .|. avChLowFrequency
avChLayout6point0 =           avChLayout5point0 .|. avChBackCenter
avChLayout6point0Front =     avChLayout22 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter
avChLayoutHexagonal =         avChLayout5point0Back .|. avChBackCenter
avChLayout6point1 =           avChLayout5point1 .|. avChBackCenter
avChLayout6point1Back =      avChLayout5point1Back .|. avChBackCenter
avChLayout6point1Front =     avChLayout6point0Front .|. avChLowFrequency
avChLayout7point0 =           avChLayout5point0 .|. avChBackLeft .|. avChBackRight
avChLayout7point0Front =     avChLayout5point0 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter
avChLayout7point1 =           avChLayout5point1 .|. avChBackLeft .|. avChBackRight
-- avChLayout7point1Wide =      avChLayout5point1 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter
-- avChLayout7point1WideBack = avChLayout5point1Back .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter
avChLayoutOctagonal =         avChLayout5point0 .|. avChBackLeft .|. avChBackCenter .|. avChBackRight
-- avChLayoutHexadecagonal =     avChLayoutOctagonal .|. avChWideLeft .|. avChWideRight .|. avChTopBackLeft .|. avChTopBackRight .|. avChTopBackCenter .|. avChTopFrontCenter .|. avChTopFrontLeft .|. avChTopFrontRight
avChLayoutStereoDownmix =    avChStereoLeft .|. avChStereoRight



<|start_filename|>demo/VPlay.hs<|end_filename|>
{-# 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 Data.IORef

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
            SDL.KeyboardEvent ev ->
              SDL.keysymKeycode (SDL.keyboardEventKeysym ev) == SDL.KeycodeEscape
            _             -> 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

  -- First frame begins.
  timeRef <- liftIO . newIORef =<< SDL.time

  liftIO $ whileJust_ (nothingOnQuit getTexture) $
    \ (next, time) -> do

      {- Rendering. -}

      -- Rendering start time.
      rStartTime <- liftIO $ readIORef timeRef

      renderTexture next

      -- Finish time of rendering.
      rFinishTime <- SDL.time :: IO Double

      {- 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

      -- Next frame begins.
      liftIO . writeIORef timeRef =<< SDL.time

  {- 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.
      textureWidth <- liftIO $ getWidth ctx
      textureHeight <- liftIO $ getHeight ctx

      -- Compute window size. If the pixels aren't square, stretch the window,
      -- SDL will automatically scale the texture to fit.
      par <- liftIO $ guessAspectRatio ctx

      let pixelAspectRatio :: Double
          pixelAspectRatio = fromIntegral (numerator par) / fromIntegral (denomenator par)

          windowWidth, windowHeight :: CInt
          windowWidth = round (pixelAspectRatio * fromIntegral textureWidth)
          windowHeight = textureHeight

      -- Create window, renderer and texture.
      window   <- createWindow windowWidth windowHeight
      renderer <- createRenderer window
      texture  <- createTexture renderer textureWidth textureHeight

      -- 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 ()


<|start_filename|>demo/AudioExtract.hs<|end_filename|>
module Main where

import           Codec.FFmpeg
import           Codec.FFmpeg.AudioStream
import           Codec.FFmpeg.Decode
import           Codec.FFmpeg.Encode
import           Codec.FFmpeg.Resampler
import           Control.Monad.Except
import           System.Environment


main :: IO ()
main = do initFFmpeg
          args <- getArgs

          case args of
            [fname, outname] -> do
              eRes <- runExceptT $ frameAudioReader (File fname)
              case eRes of
                Left er -> error er
                Right (as, getFrame, cleanup) -> do
                  putStrLn $ "bitrate : " ++ show (asBitRate as)
                  putStrLn $ "sample rate : " ++ show (asSampleRate as)
                  putStrLn $ "sample format : " ++
                      show (getSampleFormatInt (asSampleFormat as))
                  putStrLn $ "channel layout : " ++ show (asChannelLayout as)
                  putStrLn $ "channel count : " ++ show (asChannelCount as)
                  let inParams = AudioParams
                                  { apChannelLayout = asChannelLayout as
                                  , apSampleRate = asSampleRate as
                                  , apSampleFormat = asSampleFormat as
                                  }
                      outParams = AudioParams
                                  { apChannelLayout = asChannelLayout as
                                  , apSampleRate = 44100
                                  , apSampleFormat = asSampleFormat as
                                  }
                      encParams = AEncodingParams
                                  { aepChannelLayout = apChannelLayout outParams
                                  , aepSampleRate = apSampleRate outParams
                                  , aepSampleFormat = apSampleFormat outParams
                                  , aepPreset = ""
                                  , aepFormatName = Nothing
                                  }
                  (mCtx, audWriter) <- audioWriter encParams outname
                  case mCtx of
                    Nothing -> error "Didn't get audio context"
                    Just ctx -> do
                      (sendFrame, getResampledFrame) <- makeResampler ctx inParams outParams
                      let go :: Int -> IO ()
                          go i = do
                            mFrame <- getFrame
                            case mFrame of
                              Nothing -> readAndWrite
                              Just frame -> do
                                sendFrame frame
                                readAndWrite
                                go (i+1)
                          readAndWrite = do
                            mFrame <- getResampledFrame
                            case mFrame of
                              Nothing -> return ()
                              Just frame -> do
                                audWriter (Just frame)
                                readAndWrite
                      go 1
                      audWriter Nothing

                      cleanup
                      return ()
              return ()
            _ -> putStrLn usage
  where
    usage = "Supply an input video and output filename to extract the audio file to a mp3 file"


<|start_filename|>src/Codec/FFmpeg/Encode.hsc<|end_filename|>
{-# LANGUAGE ForeignFunctionInterface #-}
-- | Video encoding API. Includes FFI declarations for the underlying
-- FFmpeg functions, wrappers for these functions that wrap error
-- condition checking, and high level Haskellized interfaces.
--
-- Note: If you need to import this module, consider qualifying the
-- import.
module Codec.FFmpeg.Encode where
import Codec.FFmpeg.Common
import Codec.FFmpeg.Enums
import Codec.FFmpeg.Internal.Linear
import Codec.FFmpeg.Resampler
import Codec.FFmpeg.Scaler
import Codec.FFmpeg.Types
import Codec.Picture
import Control.Monad (when, void)
import Data.Bits
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Traversable (for)
import Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
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

import Foreign.Ptr
import Foreign.Storable

#include <libavformat/avformat.h>

-- Based on the FFmpeg muxing example
-- http://www.ffmpeg.org/doxygen/2.1/doc_2examples_2muxing_8c-example.html

-- * FFI Declarations

foreign import ccall "avcodec_find_encoder"
  avcodec_find_encoder :: AVCodecID -> IO AVCodec

foreign import ccall "avcodec_find_encoder_by_name"
  avcodec_find_encoder_by_name :: CString -> IO AVCodec

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

foreign import ccall "av_freep"
  av_freep :: Ptr (Ptr a) -> IO ()

foreign import ccall "av_guess_format"
  av_guess_format :: CString -> CString -> CString -> IO AVOutputFormat

foreign import ccall "avformat_alloc_output_context2"
  avformat_alloc_output_context2 :: Ptr AVFormatContext -> AVOutputFormat
                                 -> CString -> CString -> IO CInt

foreign import ccall "avformat_new_stream"
  avformat_new_stream :: AVFormatContext -> AVCodec -> IO AVStream

foreign import ccall "av_write_frame"
  av_write_frame :: AVFormatContext -> AVPacket -> IO CInt

foreign import ccall "av_interleaved_write_frame"
  av_interleaved_write_frame :: AVFormatContext -> AVPacket -> IO CInt

foreign import ccall "avformat_write_header"
  avformat_write_header :: AVFormatContext -> Ptr AVDictionary -> IO CInt

foreign import ccall "av_write_trailer"
  av_write_trailer :: AVFormatContext -> IO CInt

foreign import ccall "avio_open"
  avio_open :: Ptr AVIOContext -> CString -> AVIOFlag -> IO CInt

foreign import ccall "avio_close"
  avio_close :: AVIOContext -> IO CInt

foreign import ccall "avformat_free_context"
  avformat_free_context :: AVFormatContext -> IO ()

foreign import ccall "av_image_fill_arrays"
  av_image_fill_arrays :: Ptr (Ptr CUChar) -> Ptr CInt -> Ptr CUChar
                       -> AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt

foreign import ccall "av_image_fill_linesizes"
  av_image_fill_linesizes :: Ptr CInt -> AVPixelFormat -> CInt -> IO CInt

foreign import ccall "av_frame_make_writable"
  av_frame_make_writable :: AVFrame -> IO CInt

-- * FFmpeg Encoding Interface

-- | Minimal parameters describing the desired video output.
data EncodingParams = EncodingParams
  { epWidth  :: CInt
  , epHeight :: CInt
  , epFps    :: Int
  , epCodec  :: Maybe AVCodecID
  -- ^ If 'Nothing', then the codec is inferred from
  -- the output file name. If 'Just', then this codec
  -- is manually chosen.
  , epPixelFormat :: Maybe AVPixelFormat
  -- ^ If 'Nothing', automatically chose a pixel format
  -- based on the output codec. If 'Just', force the
  -- selected pixel format.
  , epPreset :: String
  -- ^ Encoder-specific hints. For h264, the default
  -- preset is @\"medium\"@ (other options are
  -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,
  -- setting this to @\"dither\"@ will enable dithering
  -- during the palettization process. This will
  -- improve image quality, but result in a larger
  -- file.
  , epFormatName :: Maybe String
  -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer
  -- from the output file name. If 'Just', the string value
  -- should be the one available in @ffmpeg -formats@.
  }

-- | Minimal parameters describing the desired audio/video output.
data AVEncodingParams = AVEncodingParams
  { avepWidth  :: CInt
  , avepHeight :: CInt
  , avepFps    :: Int
  , avepCodec  :: Maybe AVCodecID
  -- ^ If 'Nothing', then the codec is inferred from
  -- the output file name. If 'Just', then this codec
  -- is manually chosen.
  , avepPixelFormat :: Maybe AVPixelFormat
  -- ^ If 'Nothing', automatically chose a pixel format
  -- based on the output codec. If 'Just', force the
  -- selected pixel format.
  , avepChannelLayout :: CULong
  -- ^ Channel layout for the audio stream
  , avepSampleRate :: CInt
  -- ^ Sample rate for the audio stream
  , avepSampleFormat :: AVSampleFormat
  -- ^ Sample format for the audio stream
  , avepPreset :: String
  -- ^ Encoder-specific hints. For h264, the default
  -- preset is @\"medium\"@ (other options are
  -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,
  -- setting this to @\"dither\"@ will enable dithering
  -- during the palettization process. This will
  -- improve image quality, but result in a larger
  -- file.
  , avepFormatName :: Maybe String
  -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer
  -- from the output file name. If 'Just', the string value
  -- should be the one available in @ffmpeg -formats@.
  }

-- | Minimal parameters describing the desired audio/video output.
data AEncodingParams = AEncodingParams
  { aepChannelLayout :: CULong
  -- ^ Channel layout for the audio stream
  , aepSampleRate :: CInt
  -- ^ Sample rate for the audio stream
  , aepSampleFormat :: AVSampleFormat
  -- ^ Sample format for the audio stream
  , aepPreset :: String
  -- ^ Encoder-specific hints. For h264, the default
  -- preset is @\"medium\"@ (other options are
  -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec,
  -- setting this to @\"dither\"@ will enable dithering
  -- during the palettization process. This will
  -- improve image quality, but result in a larger
  -- file.
  , aepFormatName :: Maybe String
  -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer
  -- from the output file name. If 'Just', the string value
  -- should be the one available in @ffmpeg -formats@.
  }

data VideoParams = VideoParams
  { vpWidth  :: CInt
  , vpHeight :: CInt
  , vpFps    :: Int
  , vpCodec  :: Maybe AVCodecID
  , vpPixelFormat :: Maybe AVPixelFormat
  , vpPreset :: String
  }

class HasVideoParams a where
  extractVideoParams :: a -> VideoParams

instance HasVideoParams EncodingParams where
  extractVideoParams ep = VideoParams
    { vpWidth  = epWidth ep
    , vpHeight = epHeight ep
    , vpFps    = epFps ep
    , vpCodec  = epCodec ep
    , vpPixelFormat = epPixelFormat ep
    , vpPreset = epPreset ep
    }

instance HasVideoParams AVEncodingParams where
  extractVideoParams ep = VideoParams
    { vpWidth  = avepWidth ep
    , vpHeight = avepHeight ep
    , vpFps    = avepFps ep
    , vpCodec  = avepCodec ep
    , vpPixelFormat = avepPixelFormat ep
    , vpPreset = avepPreset ep
    }

class HasAudioParams a where
  extractAudioParams :: a -> AudioParams

instance HasAudioParams AEncodingParams where
  extractAudioParams ep = AudioParams
    { apChannelLayout = aepChannelLayout ep
    , apSampleRate = aepSampleRate ep
    , apSampleFormat = aepSampleFormat ep
    }

instance HasAudioParams AVEncodingParams where
  extractAudioParams ep = AudioParams
    { apChannelLayout = avepChannelLayout ep
    , apSampleRate = avepSampleRate ep
    , apSampleFormat = avepSampleFormat ep
    }

-- | Use default parameters for a video of the given width and
-- height, forcing the choice of the h264 encoder.
defaultH264 :: CInt -> CInt -> EncodingParams
defaultH264 w h =
  EncodingParams
    { epWidth = w
    , epHeight = h
    , epFps = 30
    , epCodec = (Just avCodecIdH264)
    , epPixelFormat = Nothing
    , epPreset = "medium"
    , epFormatName = Nothing
    }

-- | Use default parameters for a video of the given width and
-- height. The output format is determined by the output file name.
defaultParams :: CInt -> CInt -> EncodingParams
defaultParams w h =
  EncodingParams
    { epWidth = w
    , epHeight = h
    , epFps = 30
    , epCodec = Nothing
    , epPixelFormat = Nothing
    , epPreset = ""
    , epFormatName = Nothing
    }

-- | Determine if the bitwise intersection of two values is non-zero.
checkFlag :: Bits a => a -> a -> Bool
checkFlag flg = \x -> (flg .&. x) /= allZeroBits
  where allZeroBits = clearBit (bit 0) 0

-- | Find and initialize the requested encoder, and add a video stream
-- to the output container.
initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext)
initStream ep oc = initVideoStream (extractVideoParams ep) oc

initVideoStream :: VideoParams -> AVFormatContext -> IO (AVStream, AVCodecContext)
initVideoStream vp _
  | (vpWidth vp `rem` 2, vpHeight vp `rem` 2) /= (0,0) =
    error "Video dimensions must be multiples of two"
initVideoStream vp oc = do
  -- Use the codec suggested by the output format, or override with
  -- the user's choice.
  codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (vpCodec vp)
  cod <- avcodec_find_encoder codec
  when (getPtr cod == nullPtr)
       (error "Couldn't find encoder")

  st <- avformat_new_stream oc cod
  getNumStreams oc >>= setId st . subtract 1
  let framePeriod = AVRational 1 (fromIntegral $ vpFps vp)
      frameRate = AVRational (fromIntegral $ vpFps vp) 1
  setTimeBase st framePeriod
  ctx <- getCodecContext st
  setWidth ctx (vpWidth vp)
  setHeight ctx (vpHeight vp)
  setTimeBase ctx framePeriod
  setFrameRate ctx frameRate
  setPixelFormat ctx $ case vpPixelFormat vp of
                         Just fmt -> fmt
                         Nothing
                           | codec == avCodecIdRawvideo -> avPixFmtRgb24
                           | codec == avCodecIdGif -> avPixFmtPal8
                           | otherwise -> avPixFmtYuv420p

  -- 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)
#else
    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 ->
        getPrivData ctx >>= \pd -> av_opt_set pd kStr vStr 0

  rOpen <- open_codec ctx cod nullPtr
  when (rOpen < 0) (error "Couldn't open codec")

  return (st, ctx)

initAudioStream :: AudioParams
                -> AVFormatContext
                -> IO (AVStream, AVCodec, AVCodecContext)
initAudioStream params oc = do
  codecId <- getAudioCodecID =<< getOutputFormat oc
  print codecId
  cod <- avcodec_find_encoder codecId
  when (getPtr cod == nullPtr) (avError "Could not find audio codec")

  st <- avformat_new_stream oc cod
  getNumStreams oc >>= setId st . subtract 1
  setTimeBase st (AVRational 1 (apSampleRate params))

  ctx <- avcodec_alloc_context3 cod

  supportedSampleRates <- listSupportedSampleFormats cod
  let found = not (null supportedSampleRates)
  when (not found) $ avError "Could not find supported sample rate"
  -- TODO: check that these are valid
  setSampleFormat ctx (apSampleFormat params)
  setSampleRate ctx (apSampleRate params)

  setChannelLayout ctx (apChannelLayout params)

  runWithError "Could not open audio codec" (open_codec ctx cod nullPtr)

  codecParams <- getCodecParams st
  runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx)

  return (st, cod, ctx)


-- | Initialize a temporary YUV frame of the same resolution as the
-- output video stream. We well convert RGB frames using this frame as
-- a destination before encoding the video frame.
initTempFrame :: VideoParams -> AVPixelFormat -> IO AVFrame
initTempFrame vp fmt = do
  frame <- frame_alloc_check
  setPixelFormat frame fmt
  setWidth frame (vpWidth vp)
  setHeight frame (vpHeight vp)
  setPts frame 0

  -- For palettized images, we will provide our own buffer.
  if fmt == avPixFmtRgb8 || fmt == avPixFmtPal8
  then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (vpWidth vp)
          when (r < 0) (error "Error filling temporary frame line sizes")
  else frame_get_buffer_check frame 32
  return frame

-- | Allocate an output context inferring the codec from the given
-- file name.
allocOutputContext :: Maybe String -> FilePath -> IO AVFormatContext
allocOutputContext outputFormat fname = do
  let withFormat = case outputFormat of
        Just f -> withCString f
        Nothing -> (\f -> f nullPtr)
  oc <- alloca $ \ocTmp -> do
        r <- withCString fname $ \fname' ->
                withFormat $ \format ->
                  avformat_alloc_output_context2
                    ocTmp (AVOutputFormat nullPtr)
                    format fname'
        when (r < 0)
              (error "Couldn't allocate output format context")
        peek ocTmp
  when (getPtr oc == nullPtr)
       (error "Couldn't allocate iutput AVFormatContext")
  return oc

-- | Open the given file for writing.
avio_open_check :: AVFormatContext -> String -> IO ()
avio_open_check oc fname =
  do r <- withCString fname $ \cstr ->
            avio_open (hasIOContext oc) cstr avioFlagWrite
     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) (error "Error closing IO")

-- | Returns 'True' if the 'AVPacket' was updated with new output
-- 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
  where frame' = fromMaybe (AVFrame nullPtr) frame

-- | Allocate the stream private data and write the stream header to
-- an output media file.
write_header_check :: AVFormatContext -> IO ()
write_header_check oc =
  void $ runWithError "write header" (avformat_write_header oc nullPtr)

-- | Write a packet to an output media file.
write_frame_check :: AVFormatContext -> AVPacket -> IO ()
write_frame_check oc pkt = do r <- av_write_frame oc pkt
                              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) (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
-- 'av_image_fill_arrays''s expectations. This is slow.
palettizeRGB8 :: VideoParams -> V.Vector CUChar -> V.Vector CUChar
palettizeRGB8 vp = \pix -> V.create $
  do let pix' = V.unsafeCast pix :: V.Vector (V3 CUChar)
     m <- VM.new (numPix + 1024)
     V.mapM_ (\i -> let p = searchPal $ fromIntegral <$> (pix' V.! i)
                    in VM.unsafeWrite m i p)
             (V.enumFromN 0 numPix)
     VM.set (VM.unsafeSlice numPix 1024 m) 0
     return m
  where numPix = fromIntegral $ vpWidth vp * vpHeight vp
        pal :: V.Vector (V3 CInt)
        pal = V.generate 256 $ \i' ->
                let i = fromIntegral i'
                in V3 ((i `shiftR` 5) * 36)
                      (((i `shiftR` 2) .&. 7) * 36)
                      ((i .&. 3) * 85)
        searchPal = fromIntegral . flip V.minIndexBy pal . comparing . qd

-- | High quality dithered, median cut palette using 'palettize'. The
-- result is packed such that the BGRA palette is laid out
-- contiguously following the palettized image data.
palettizeJuicy :: VideoParams -> V.Vector CUChar -> V.Vector CUChar
palettizeJuicy vp pix =
  let (pix', pal) = palettize (PaletteOptions MedianMeanCut doDither 256)
                              (mkImage $ V.unsafeCast pix)
      pal' = V.map (\(V3 r g b) -> V4 b g r (255::CUChar))
                  (V.unsafeCast $ imageData pal)
  in V.unsafeCast (imageData pix') V.++ V.unsafeCast pal'
  where mkImage = Image (fromIntegral $ vpWidth vp) (fromIntegral $ vpHeight vp)
        doDither = vpPreset vp == "dither"

{-# DEPRECATED frameWriter "Please use videoWriter instead." #-}
frameWriter :: EncodingParams -> FilePath
            -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
frameWriter ep fname = do
  let sp = JustVideo (extractVideoParams ep)
  writerContext <- avWriter (epFormatName ep) sp fname
  return (avwVideoWriter writerContext)

-- | Open a target file for writing a video stream. The function
-- returned may be used to write image frames (specified by a pixel
-- format, resolution, and pixel data). If this function is applied to
-- 'Nothing', then the output stream is closed. Note that 'Nothing'
-- /must/ be provided to properly terminate video encoding.
--
-- Support for source images that are of a different size to the
-- output resolution is limited to non-palettized destination formats
-- (i.e. those that are handled by @libswscaler@). Practically, this
-- means that animated gif output only works if the source images are
-- of the target resolution.
videoWriter :: EncodingParams -> FilePath
            -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
videoWriter ep fname = do
  let sp = JustVideo (extractVideoParams ep)
  writerContext <- avWriter (epFormatName ep) sp fname
  return (avwVideoWriter writerContext)

data StreamParams =
    JustVideo VideoParams
  | JustAudio AudioParams
  | AudioVideo AudioParams VideoParams

withVideoParams :: StreamParams -> a -> (VideoParams -> a) -> a
withVideoParams sp def f =
  case sp of
    JustVideo vp -> f vp
    AudioVideo _ vp -> f vp
    _ -> def

withAudioParams :: StreamParams -> a -> (AudioParams -> a) -> a
withAudioParams sp def f =
  case sp of
    JustAudio ap -> f ap
    AudioVideo ap _ -> f ap
    _ -> def

-- | Open a target for writing an audio stream.
audioWriter :: AEncodingParams
            -> FilePath
            -> IO (Maybe AVCodecContext, Maybe AVFrame -> IO ())
audioWriter ep fname = do
  let sp = JustAudio (extractAudioParams ep)
  writerContext <- avWriter (aepFormatName ep) sp fname
  return (avwAudioCodecContext writerContext, avwAudioWriter writerContext)

data AVWriterContext = AVWriterContext
  { avwVideoCodecContext :: Maybe AVCodecContext
  , avwAudioCodecContext :: Maybe AVCodecContext
  , avwVideoWriter :: Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
  , avwAudioWriter :: Maybe AVFrame -> IO ()
  }

-- | Open a target for writing a video and audio file.
audioVideoWriter :: AVEncodingParams -> FilePath -> IO AVWriterContext
audioVideoWriter ep fname = do
  let sp = AudioVideo (extractAudioParams ep) (extractVideoParams ep)
  avWriter (avepFormatName ep) sp fname

-- | For internal use only. Use 'videoWriter', 'audioWriter', or 'audioVideoWriter' instead.
avWriter :: Maybe String
         -> StreamParams
         -> FilePath
         -> IO AVWriterContext
avWriter outputFormat sp fname = do
  oc <- allocOutputContext outputFormat fname
  outputFormat <- getOutputFormat oc
  audioCodecId <- getAudioCodecID outputFormat
  videoCodecId <- getVideoCodecID outputFormat

  -- Initializing the streams needs to be done before opening the file
  -- and checking the header because it can modify fields that are used
  -- for time scaling so we have this rather ugly code.
  mVideoStream <- withVideoParams sp (return Nothing) $ \vp ->
                    (Just <$> initVideoStream vp oc)
  mAudioStream <- withAudioParams sp (return Nothing) $ \ap ->
                    (Just <$> initAudioStream ap oc)
  avio_open_check oc fname
  numStreams <- getNumStreams oc
  write_header_check oc

  alreadyClosedRef <- newIORef False
  let writeClose = do
        alreadyClosed <- readIORef alreadyClosedRef
        when (not alreadyClosed) $ do
          write_trailer_check oc
          modifyIORef alreadyClosedRef (const True)

      initializeVideo :: AVStream
                      -> AVCodecContext
                      -> VideoParams
                      -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
      initializeVideo st ctx vp = do
        dstFmt <- getPixelFormat ctx
        dstFrame <- initTempFrame vp dstFmt
        let dstInfo = ImageInfo (vpWidth vp) (vpHeight vp) dstFmt

        -- Initialize the scaler that we use to convert RGB -> dstFmt
        -- Note that libswscaler does not support Pal8 as an output format.
        sws <- if dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8
              then swsInit (ImageInfo (vpWidth vp) (vpHeight vp) avPixFmtRgb24)
                            dstInfo swsBilinear
                    >>= fmap Just . newIORef
              else return Nothing

        pkt <- AVPacket <$> av_malloc (fromIntegral packetSize)
        setPts pkt 0

        stIndex <- getStreamIndex st

        -- Frame number ioref. We use this to determine whether we should
        -- increment the frame PTS; we only want to do this for frames after
        -- the first one since we want the first frame PTS to be zero.
        frameNum <- newIORef (0::Int)

        let framePeriod = AVRational 1 (fromIntegral $ vpFps vp)
        fps <- getFps ctx

          -- The stream time_base can be changed by the call to
          -- 'write_header_check', so we read it back here to establish a way
          -- of scaling the nominal, desired frame rate (given by
          -- 'framePeriod') to the stream's time_base.
        tb <- getTimeBase st
#if LIBAVFORMAT_VERSION_MAJOR < 57
        isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags)
#endif

        let checkPalCompat
              | dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 = const True
              | otherwise = \(srcFmt, V2 srcW srcH, _) ->
                              srcFmt == avPixFmtRgb24 &&
                              srcW == vpWidth vp &&
                              srcH == vpHeight vp

            palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy vp
                       | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 vp
                       | otherwise =  Nothing
            frameTime = av_rescale_q 1 framePeriod tb
            resetPacket = do init_packet pkt
                             setPktData pkt nullPtr
                             setSize pkt 0
            writePacket = do setStreamIndex pkt stIndex
                             write_frame_check oc pkt

            copyDstData (_,_,pixels) =
              void . V.unsafeWith pixels $ \ptr ->
                av_image_fill_arrays (castPtr $ hasData dstFrame)
                                    (hasLineSize dstFrame)
                                    (castPtr ptr)
                                    dstFmt
                                    (vpWidth vp)
                                    (vpHeight vp)
                                    1

            scaleToDst sws' img = void $ swsScale sws' img dstFrame
            fillDst = maybe copyDstData scaleToDst

            -- | Gets the PTS to be used for the current frame by reading the
            -- PTS from dstFrame. If the current frame is the first frame
            -- (zero), the existing timestamp is left unmodified. Otherwise it
            -- is incremented by frameTime.
            --
            -- This also increments the current frame number stored in the
            -- frameNum IORef so the caller needn't worry about it.
            getCurrentFrameTimestamp = do
                curFrame <- readIORef frameNum
                ts <- case curFrame == 0 of
                    True -> getPts dstFrame
                    False -> (+ frameTime) <$> getPts dstFrame
                modifyIORef frameNum (+1)
                return ts
#if LIBAVFORMAT_VERSION_MAJOR < 57
            addRaw Nothing = return ()
            addRaw (Just (_, _, pixels)) =
              do resetPacket
                getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey)
                --setSize pkt (fromIntegral $ V.length pixels)
                setSize pkt (fromIntegral pictureSize)
                timeStamp <- getCurrentFrameTimestamp
                setPts dstFrame timeStamp
                setPts pkt timeStamp
                -- getPts dstFrame >>= setDts pkt
                V.unsafeWith pixels $ \ptr -> do
                  setData pkt (castPtr ptr)
                  writePacket
#endif
            addEncoded Nothing = do resetPacket
                                    encode_video_check ctx pkt Nothing >>=
                                      flip when (writePacket >> addEncoded Nothing)
            addEncoded (Just srcImg@(srcFmt, V2 srcW srcH, pixels)) =
              do resetPacket
                 when (not $ checkPalCompat srcImg)
                     (error $
                      unlines [ "Palettized output requires source images to be the "
                              , "same resolution as the output video" ])
                 let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer
                 sws' <- for sws $ \sPtr -> do
                          s <- readIORef sPtr
                          s' <- swsReset s (ImageInfo srcW srcH srcFmt) dstInfo
                                          swsBilinear
                          writeIORef sPtr s'
                          return s'
                 timeStamp <- getCurrentFrameTimestamp
                 setPts dstFrame timeStamp
                 fillDst sws' (srcFmt, V2 srcW srcH, pixels')
                 encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket
                 -- Make sure the GC hasn't clobbered our palettized pixel data
                 let (fp,_,_) = V.unsafeToForeignPtr pixels'
                 touchForeignPtr fp
#if LIBAVFORMAT_VERSION_MAJOR < 57
            addFrame = if isRaw then addRaw else addEncoded
#else
            addFrame = addEncoded
#endif
            go Nothing = do addFrame Nothing
                            writeClose
                            _ <- codec_close ctx
                            with dstFrame av_frame_free
                            av_free (getPtr pkt)
                            avio_close_check oc
                            avformat_free_context oc
            go img@(Just _) = addFrame img
        return go

      initializeAudio :: AVStream
                      -> AVCodec
                      -> AVCodecContext
                      -> IO (Maybe AVFrame -> IO ())
      initializeAudio st codec ctx = do
        if audioCodecId /= avCodecIdNone
          then do
            pkt <- av_packet_alloc
            init_packet pkt

            frameNum <- newIORef (0::Int)
            timeBase <- getTimeBase ctx

            lastPts <- newIORef 0

            let read_pkts = do
                  ret <- avcodec_receive_packet ctx pkt
                  -- TODO: Distinguish between temp and permanent errors with EAGAIN
                  if ret /= 0
                    then return ()
                    else do
                      timeBase2 <- getTimeBase st
                      packet_rescale_ts pkt timeBase timeBase2
                      setStreamIndex pkt =<< getStreamIndex st
                      -- TODO: Not sure this pts will be exactly accurate.
                      -- Also, we need to set duration too because it doesn't seem to be set.
                      setPts pkt =<< readIORef lastPts
                      runWithError "Error while writing audio frame"
                                  (av_interleaved_write_frame oc pkt)
                      return ()
                writeAudioFrame :: Maybe AVFrame -> IO ()
                writeAudioFrame Nothing = do
                  read_pkts
                  writeClose
                  codec_close ctx
                  return ()
                writeAudioFrame (Just frame) = writeAudioFrame' frame

                writeAudioFrame' :: AVFrame -> IO ()
                writeAudioFrame' frame = do
                  numSamples <- getNumSamples frame
                  sampleRate <- getSampleRate ctx

                  onGoingSampleCount <- readIORef frameNum
                  let samplesCount = av_rescale_q (fromIntegral onGoingSampleCount)
                                              (AVRational 1 sampleRate) timeBase
                  setPts frame (av_rescale_q samplesCount (AVRational 1 sampleRate) timeBase)
                  newPts <- getPts frame
                  modifyIORef lastPts (const newPts)
                  modifyIORef frameNum (+ fromIntegral numSamples)

                  runWithError "Error encoding audio"
                      (avcodec_send_frame ctx frame)
                  read_pkts
            return writeAudioFrame
          else
            return $ \_ -> return ()

  videoWriter <- case mVideoStream of
                   Just (vs, ctx) ->
                     withVideoParams sp (return (\_ -> return ()))
                       (initializeVideo vs ctx)
                   Nothing -> return (\_ -> return ())
  audioWriter <- case mAudioStream of
                   Just (as, codec, ctx) ->
                     withAudioParams sp (return $ \_ -> return ())
                       (const (initializeAudio as codec ctx))
                   Nothing -> return $ \_ -> return ()

  return $ AVWriterContext
    { avwVideoCodecContext = snd <$> mVideoStream
    , avwAudioCodecContext = (\(_, _, ctx) -> ctx) <$> mAudioStream
    , avwVideoWriter = videoWriter
    , avwAudioWriter = audioWriter
    }

-- | Open a target file for writing a video stream. The function
-- returned may be used to write RGB images of the resolution given by
-- the provided 'EncodingParams' (i.e. the same resolution as the
-- output video). If this function is applied to 'Nothing', then the
-- output stream is closed. Note that 'Nothing' /must/ be provided to
-- properly terminate video encoding. Throws an error if you do not
-- provide a 'EncodingParams' without 'VideoParams'
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)


<|start_filename|>demo/Transcode.hs<|end_filename|>
module Main where

import System.Environment (getArgs)
import qualified Codec.FFmpeg as FF
import qualified Codec.FFmpeg.Encode as FF
import Codec.Picture

type Frame = Image PixelRGB8

usage :: String
usage =
  unlines [ "Usage: transcode inputFile outputFile [outputFormat] [outputWidth] [outputHeight]"
          , "  Example: transcode rtmp://localhost/app/one rtmp://localhost/app/two flv 640 480"
          , ""
          , "  Copies the content from inputFile to outputFile using H264."
          , "  Defaults:"
          , "  outputFormat=flv"
          , "  outputWidth=640"
          , "  outputHeight=480"
          ]

main :: IO ()
main = do
  args <- getArgs
  FF.initFFmpeg
  FF.setLogLevel FF.avLogDebug
  case args of
    [from, to] -> copy from to "flv" 640 480
    [from, to, format, w, h] -> copy from to format (read w) (read h)
    _ -> error usage

copy :: FilePath -> FilePath -> String -> Int -> Int -> IO ()
copy from to format w h = do
  let ep = (FF.defaultH264 (fromIntegral w) (fromIntegral h))
            -- { FF.epFormatName = Just format }
            -- TODO: get this working again
  (getFrame, cleanup) <- FF.imageReader (FF.File from)
  putFrame <- FF.imageWriter ep to
  loop getFrame cleanup putFrame (\x -> return x)

loop :: IO (Maybe Frame)
     -> IO cleanup
     -> (Maybe Frame -> IO ())
     -> (Frame -> IO Frame)
     -> IO cleanup
loop getFrame finishReading putFrame editFrame = do
  maybeFrame <- getFrame
  case maybeFrame of
    Nothing -> do
      putFrame Nothing
      finishReading
    Just x -> do
      x' <- editFrame x
      putFrame (Just x')
      loop getFrame finishReading putFrame editFrame


<|start_filename|>demo/AudioSin.hs<|end_filename|>
{-# LANGUAGE MultiWayIf #-}
module Main where

import           Codec.FFmpeg
import           Codec.FFmpeg.AudioStream
import           Codec.FFmpeg.Common
import           Codec.FFmpeg.Encode
import           Codec.FFmpeg.Enums
import           Codec.FFmpeg.Juicy
import           Codec.FFmpeg.Types
import           Codec.Picture
import           Control.Monad.Except
import           Data.IORef
import           Foreign.C.Types
import           Foreign.Marshal.Array
import           Foreign.Ptr
import           Foreign.Storable
import           System.Environment

-- Simple Music DSL
type Sound = Float -> Float

volume :: Float -> Sound -> Sound
volume v s t = v * (s t)

mkNote :: Float -> Sound
mkNote f = \t -> sin (f * 2 * pi * t)

a4 :: Sound
a4 = mkNote 440

c4 :: Sound
c4 = mkNote 261.6256

d4 :: Sound
d4 = mkNote 293.6648

e4 :: Sound
e4 = mkNote 329.6276

f4 :: Sound
f4 = mkNote 349.2282

g4 :: Sound
g4 = mkNote 391.9954

b4 :: Sound
b4 = mkNote 493.8833

c5 :: Sound
c5 = mkNote 523.2511

e5 :: Sound
e5 = mkNote 659.2551

combineSounds :: [Sound] -> Sound
combineSounds snds t = sum $ map (\s -> s t) snds

-- Take sounds and their duration and put them in order
sequenceSounds :: [(Float, Sound)] -> Sound
sequenceSounds snds tin = go tin snds
  where
    go t [(_,snd)] = snd t
    go t ((dur,snd):rest)
      | t <= dur   = snd t
      | otherwise = go (t-dur) rest
    go _ _ = 0

cMaj7 = combineSounds [ volume 0.23 c4, volume 0.23 e4, volume 0.23 g4, volume 0.23 b4 ]
dMin7 = combineSounds [ volume 0.23 d4, volume 0.23 f4, volume 0.23 a4, volume 0.23 c5 ]
g7    = combineSounds [ volume 0.23 g4, volume 0.23 a4, volume 0.23 c5, volume 0.23 e5 ]
-- ii - V7 - I jazz chord progression
twoFiveOne = sequenceSounds [(1, dMin7), (1, g7), (1, cMaj7)]

mkImage :: Int -> Int -> PixelRGB8 -> Image PixelRGB8
mkImage w h color =
  generateImage (\_ _ -> color) w h

main :: IO ()
main = do
  initFFmpeg

  let w = 1080
      h = 720
      encParams = AVEncodingParams
                    { avepWidth = w
                    , avepHeight = h
                    , avepFps = 30
                    , avepCodec = Nothing
                    , avepPixelFormat = Nothing
                    , avepChannelLayout = avChLayoutMono
                    , avepSampleRate = 44100
                    , avepSampleFormat = avSampleFmtFltp
                    , avepPreset = ""
                    , avepFormatName = Nothing
                    }
  writerContext <- audioVideoWriter encParams "sinusoidal.mp4"
  let mCtx = avwAudioCodecContext writerContext
      videoWriter = avwVideoWriter writerContext
      audioWriter = avwAudioWriter writerContext
  case mCtx of
    Nothing -> error "Could not get audio ctx"
    Just ctx -> do
      frame <- frame_alloc_check
      setNumSamples frame =<< getFrameSize ctx
      setFormat frame . getSampleFormatInt =<< getSampleFormat ctx
      setChannelLayout frame =<< getChannelLayout ctx
      setSampleRate frame =<< getSampleRate ctx

      ch <- getChannelLayout ctx
      numChannels <- getChannels ctx

      print ("Channel Layout", ch)
      print ("Channels", numChannels)

      runWithError "Alloc buffers" (av_frame_get_buffer frame 0)

      let sampleRate = avepSampleRate encParams
      print ("sample rate", sampleRate)

      vidFrameRef <- newIORef 0 :: IO (IORef Int)
      forM_ [0..120] $ \i -> do
        av_frame_make_writable frame
        dataPtr <- castPtr <$> getData frame :: IO (Ptr CFloat)
        nbSamples <- getNumSamples frame
        forM_ [0..nbSamples-1] $ \j -> do
          let idx = fromIntegral i * fromIntegral nbSamples + fromIntegral j :: Integer
              t = fromIntegral idx / fromIntegral sampleRate
              v = twoFiveOne t
          poke (advancePtr dataPtr (fromIntegral j)) (realToFrac v)
          vidFrame <- readIORef vidFrameRef
          when (t * 30 >= fromIntegral vidFrame) $ do
            -- TODO: I'm not sure why t seems to be half the actual value but I need to do
            -- 0.5 and 1 to make the chord changes match up with the color changes
            modifyIORef vidFrameRef (+1)
            let color = if | t <= 1    -> PixelRGB8 255 0 0
                           | t <= 2    -> PixelRGB8 0 255 0
                           | otherwise -> PixelRGB8 0 0 255
                img = mkImage (fromIntegral w) (fromIntegral h) color
            videoWriter (Just (fromJuciy img))
        audioWriter (Just frame)

      videoWriter Nothing
      audioWriter Nothing


<|start_filename|>src/Codec/FFmpeg/Common.hsc<|end_filename|>
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Codec.FFmpeg.Common where
import           Codec.FFmpeg.Enums
import           Codec.FFmpeg.Types
import           Control.Exception
import           Control.Monad             (when)
import           Control.Monad.Error.Class
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Maybe
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.Marshal.Alloc     (allocaBytes, free)
import           Foreign.Marshal.Array     (advancePtr, mallocArray)
import           Foreign.Ptr
import           Foreign.Storable

foreign import ccall "avcodec_open2"
  open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt

foreign import ccall "av_frame_alloc"
  av_frame_alloc :: IO AVFrame

foreign import ccall "av_frame_get_buffer"
  av_frame_get_buffer :: AVFrame -> CInt -> IO CInt

foreign import ccall "av_frame_free"
  av_frame_free :: Ptr AVFrame -> IO ()

foreign import ccall "avcodec_close"
  codec_close :: AVCodecContext -> IO CInt

foreign import ccall "av_init_packet"
  init_packet :: AVPacket -> IO ()

foreign import ccall "av_packet_alloc"
  av_packet_alloc :: IO AVPacket

foreign import ccall "av_free_packet"
  free_packet :: AVPacket -> IO ()

foreign import ccall "av_malloc"
  av_malloc :: CSize -> IO (Ptr ())

foreign import ccall "av_free"
  av_free :: Ptr () -> IO ()

foreign import ccall "sws_getCachedContext"
  sws_getCachedContext :: SwsContext
                       -> CInt -> CInt -> AVPixelFormat
                       -> CInt -> CInt -> AVPixelFormat
                       -> SwsAlgorithm -> Ptr () -> Ptr () -> Ptr CDouble
                       -> IO SwsContext

foreign import ccall "sws_scale"
  sws_scale :: SwsContext
            -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt
            -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt

foreign import ccall "av_get_channel_layout_nb_channels"
  av_get_channel_layout_nb_channels :: CULong -> IO CInt

foreign import ccall "swr_alloc"
  swr_alloc :: IO SwrContext

foreign import ccall "swr_init"
  swr_init :: SwrContext -> IO CInt

foreign import ccall "av_opt_set_int"
  av_opt_set_int :: Ptr () -> CString -> CLong -> CInt -> IO CInt

foreign import ccall "av_opt_get_int"
  av_opt_get_int :: Ptr () -> CString -> CInt -> Ptr CULong -> IO CInt

foreign import ccall "av_opt_set_sample_fmt"
  av_opt_set_sample_fmt :: Ptr () -> CString -> AVSampleFormat -> CInt -> IO CInt

foreign import ccall "av_opt_get_sample_fmt"
  av_opt_get_sample_fmt :: Ptr () -> CString -> CInt -> Ptr AVSampleFormat -> IO CInt

foreign import ccall "avcodec_send_frame"
  avcodec_send_frame :: AVCodecContext -> AVFrame -> IO CInt

foreign import ccall "avcodec_send_packet"
  avcodec_send_packet :: AVCodecContext -> AVPacket -> IO CInt

foreign import ccall "avcodec_receive_frame"
  avcodec_receive_frame :: AVCodecContext -> AVFrame -> IO CInt

foreign import ccall "avcodec_receive_packet"
  avcodec_receive_packet :: AVCodecContext -> AVPacket -> IO CInt

foreign import ccall "av_get_channel_name"
  av_get_channel_name :: CULong -> IO CString

foreign import ccall "av_get_channel_description"
  av_get_channel_description :: CULong -> IO CString

-- Return size of buffer for image.
foreign import ccall "av_image_get_buffer_size"
  av_image_get_buffer_size
    -- 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
-- wrapping monad transformer.
wrapIOError :: (MonadIO m, MonadError String m) => IO a -> m a
wrapIOError io = liftIO (catchError (fmap Right io) (return . Left . show))
                 >>= either throwError return

newtype FFmpegException = FFmpegException String deriving Show

instance Exception FFmpegException

runWithError :: String -> IO CInt -> IO CInt
runWithError msg toRun = do
  r <- toRun
  when (r < 0) $ do
    let len = 100 -- I have no idea how long this string should be so this is a guess
    errCStr <- mallocArray len
    av_strerror r errCStr (fromIntegral len)
    errStr <- peekCString errCStr
    free errCStr
    avError $ msg ++ " : " ++ errStr
  return r

avError :: String -> IO a
avError msg = throwIO $ FFmpegException $ msg

-- * Wrappers that may throw 'IOException's.

-- | Allocate an 'AVFrame' and set its fields to default values.
frame_alloc_check :: IO AVFrame
frame_alloc_check = do r <- av_frame_alloc
                       when (getPtr r == nullPtr)
                            (error "Couldn't allocate frame")
                       return r

-- | Allocate new buffer(s) for audio or video data with the required
-- alignment. Note, for video frames, pixel format, @width@, and
-- @height@ must be set before calling this function. For audio
-- frames, sample @format@, @nb_samples@, and @channel_layout@ must be
-- set.
frame_get_buffer_check :: AVFrame -> CInt -> IO ()
frame_get_buffer_check f x = do r <- av_frame_get_buffer f x
                                when (r /= 0)
                                     (error "Failed to allocate buffers")

-- | Bytes-per-pixel for an 'AVPixelFormat'
avPixelStride :: AVPixelFormat -> Maybe Int
avPixelStride fmt
  | fmt == avPixFmtGray8  = Just 1
  | fmt == avPixFmtRgb24  = Just 3
  | fmt == avPixFmtRgba   = Just 4
  | 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

-- * FFmpeg Errors

foreign import ccall "av_strerror"
  av_strerror :: CInt -> Ptr CChar -> CSize -> IO CInt

stringError :: CInt -> IO String
stringError err =
  allocaBytes len $ \block -> do
    let buf = castPtr block
    _ <- av_strerror err buf (fromIntegral len)
    peekCString buf
  where
    len = 1000

-- | Walk a C array placing the values into a Haskell list.
-- Stop incrementing the pointer when the function returns True
walkPtrs :: Storable a
         => Ptr a -- ^ Ptr to the beginning of an array
         -> (Ptr a -> IO Bool) -- ^ Function to specify when we should terminate
         -> IO [a]
walkPtrs ptr isDone = do
  d <- isDone ptr
  if d
    then return []
    else do
      v <- peek ptr
      rest <- walkPtrs (advancePtr ptr 1) isDone
      return $ v : rest

listSupportedSampleFormats :: AVCodec -> IO [AVSampleFormat]
listSupportedSampleFormats codec = do
  fmts <- getSampleFormats codec
  walkPtrs fmts (\ptr ->
                    if ptr == nullPtr
                      then return True
                      else do
                        v <- peek ptr
                        return $ getSampleFormatInt v == -1
                )

listSupportedChannelLayouts :: AVCodec -> IO [CULong]
listSupportedChannelLayouts codec = do
  chanPtr <- getChannelLayouts codec
  walkPtrs chanPtr (\ptr ->
                    if ptr == nullPtr
                      then return True
                      else do
                        v <- peek ptr
                        return $ v == 0
                   )

listSupportedSampleRates :: AVCodec -> IO [CInt]
listSupportedSampleRates codec = do
  srPtr <- getSupportedSampleRates codec
  walkPtrs srPtr (\ptr ->
                    if ptr == nullPtr
                      then return True
                      else do
                        v <- peek ptr
                        return $ v == 0
                 )


<|start_filename|>src/Codec/FFmpeg/Resampler.hs<|end_filename|>
module Codec.FFmpeg.Resampler where

import           Codec.FFmpeg.Common
import           Codec.FFmpeg.Enums
import           Codec.FFmpeg.Types
import           Control.Concurrent.STM.TChan
import           Control.Monad                (void, when)
import           Control.Monad.STM
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.Marshal.Alloc
import           Foreign.Ptr
import           Foreign.Storable

foreign import ccall "swr_get_delay"
  swr_get_delay :: SwrContext -> CLong -> IO CLong

foreign import ccall "swr_convert"
  swr_convert :: SwrContext -> Ptr (Ptr CUChar) -> CInt
              -> Ptr (Ptr CUChar) -> CInt -> IO CInt

foreign import ccall "swr_get_out_samples"
  swr_get_out_samples :: SwrContext -> CInt -> IO CInt

data AudioParams = AudioParams
  { apChannelLayout :: CULong
  , apSampleRate    :: CInt
  , apSampleFormat  :: AVSampleFormat
  }

makeResampler :: AVCodecContext
              -> AudioParams
              -> AudioParams
              -> IO (AVFrame -> IO (), IO (Maybe AVFrame))
makeResampler ctx inParams outParams = do
  swr <- initSwrContext inParams outParams

  frameChan <- newTChanIO

  let writeFrame frame = do
        srcSamples <- getNumSamples frame
        if srcSamples == 0
           then return ()
           else do
            srcRate <- getSampleRate frame
            delay <- swr_get_delay swr (fromIntegral srcRate)
            let dstSamples = av_rescale_rnd
                            (delay + fromIntegral srcSamples)
                            (fromIntegral (apSampleRate outParams))
                            (fromIntegral srcRate) avRoundUp
                srcData = castPtr (hasData frame)
            dstDataPtr <- malloc
            lineSize <- malloc
            dstChannelCount <- av_get_channel_layout_nb_channels
                (apChannelLayout outParams)
            _ <- runWithError "Could not alloc samples"
                     (av_samples_alloc_array_and_samples dstDataPtr lineSize
                     dstChannelCount (fromIntegral dstSamples)
                     (apSampleFormat outParams) 0)
            dstData <- peek dstDataPtr
            _ <- runWithError "Error converting samples"
                     (swr_convert swr nullPtr 0 srcData srcSamples)

            frameSize <- getFrameSize ctx
            let convertLoop = do
                  outSamples <- swr_get_out_samples swr 0
                  if outSamples < frameSize * dstChannelCount
                     then return ()
                     else do
                       aframe <- allocAudioFrame ctx
                       _outSamples <- swr_convert swr (castPtr $ hasData aframe)
                                                      frameSize nullPtr 0

                       atomically $ writeTChan frameChan aframe
                       convertLoop

            convertLoop
            free dstData
            free lineSize
            return ()

      allocAudioFrame :: AVCodecContext -> IO AVFrame
      allocAudioFrame actx = do
        frame <- av_frame_alloc
        when (getPtr frame == nullPtr)
            (error "Error allocating an audio frame")

        setFormat frame . getSampleFormatInt =<< getSampleFormat actx
        setChannelLayout frame =<< getChannelLayout actx
        setSampleRate frame =<< getSampleRate actx
        fs <- (do fs <- getFrameSize actx
                  if fs == 0
                    then return 1000
                    else return fs)
        setNumSamples frame fs

        _ <- runWithError "Error allocating an audio buffer"
                          (av_frame_get_buffer frame 0)
        return frame

      readFrame = do
        mFrame <- atomically $ tryReadTChan frameChan
        case mFrame of
          Nothing -> return Nothing
          Just _  -> return mFrame

  return (writeFrame, readFrame)

initSwrContext :: AudioParams -> AudioParams -> IO SwrContext
initSwrContext inParams outParams = do
  swr <- swr_alloc
  when (getPtr swr == nullPtr) (error "Could not allocate resampler context")
  let set_int str i = do
        cStr <- newCString str
        _ <- av_opt_set_int (getPtr swr) cStr (fromIntegral i) 0
        free cStr
      set_sample_fmt str fmt = do
        cStr <- newCString str
        _ <- av_opt_set_sample_fmt (getPtr swr) cStr fmt 0
        free cStr

  -- set_int "in_channel_count" (aoChannelCount inParams)
  set_int "in_channel_layout" (apChannelLayout inParams)
  set_int "in_sample_rate" (apSampleRate inParams)
  set_sample_fmt "in_sample_fmt" (apSampleFormat inParams)
  -- set_int "out_channel_count" (aoChannelCount outParams)
  set_int "out_channel_layout" (apChannelLayout inParams)
  set_int "out_sample_rate" (apSampleRate outParams)
  set_sample_fmt "out_sample_fmt" (apSampleFormat outParams)

  void $ runWithError "Failed to initialize the resampling context" (swr_init swr)

  -- let get_int str = do
  --       cStr <- newCString str
  --       p <- malloc
  --       r <- av_opt_get_int (getPtr swr) cStr 0 p
  --       v <- peek p
  --       free p
  --       return v
  --     get_sample_fmt str = do
  --       cStr <- newCString str
  --       p <- malloc
  --       r <- av_opt_get_sample_fmt (getPtr swr) cStr 0 p
  --       fmt <- peek p
  --       free p
  --       return fmt

  return swr


<|start_filename|>demo/Main.hs<|end_filename|>
module Main where
import Codec.FFmpeg
import Codec.Picture
import Control.Monad (replicateM_)
import qualified Data.Time.Clock as C
import qualified Data.Vector.Storable as V
import System.Environment
import qualified System.Info as Info
import Control.Monad (unless)

-- The example used in the README
firstFrame :: IO (Maybe DynamicImage)
firstFrame = do initFFmpeg
                (getFrame, cleanup) <- imageReader (File "myVideo.mov")
                (fmap ImageRGB8 <$> getFrame) <* cleanup

-- | Generate a video that pulses from light to dark.
pulseVid :: IO ()
pulseVid =
  do boom <- imageWriter (defaultParams sz sz) "pulse.mov"
     let boom' = (boom :: Maybe (Image Pixel8) -> IO ())  . Just . Image sz sz
         go :: Int -> Int -> Int -> IO ()
         go 600 _ _ = boom Nothing
         go n d i = do boom' $ V.replicate (sz*sz) (fromIntegral i)
                       let i' = i + d
                       if i' < 100
                       then go (n+1) 1 101
                       else if i' > 255
                            then go (n+1) (-1) 254
                            else go (n+1) d i'
     go 0 (-1) 255
  where sz :: Integral a => a
        sz = 64

-- | Generate a video that fades from white to gray to white.
testEncode :: IO ()
testEncode = initFFmpeg >> 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!"

-- | @loopFor timeSpan action@ repeats @action@ until at least @timeSpan@
-- seconds have elapsed.
loopFor :: Double -> IO () -> IO ()
loopFor time m =
  do start <- C.getCurrentTime
     let go = do m
                 now <- C.getCurrentTime
                 unless (realToFrac (C.diffUTCTime now start) >= time) go
     go

testCamera :: IO ()
testCamera =
  do initFFmpeg -- Defaults to quiet (minimal) logging
     -- setLogLevel avLogInfo -- Restore standard ffmpeg logging

     (getFrame, cleanup) <- imageReader $
       case Info.os of
         "linux" ->
           let cfg = CameraConfig (Just 30) Nothing (Just "mjpeg")
                                  -- (Just "v4l2")
           in Camera "/dev/video0" cfg
         "darwin" -> Camera "0:0" defaultCameraConfig
         _ -> error "Unsure how to identify a default camera input"

     frame1 <- getFrame
     case frame1 of
       img@(Just (Image w h _)) ->
         do let [w',h'] = map fromIntegral [w,h]
            writeFrame <- imageWriter (defaultParams w' h') "camera.mov"
            writeFrame (img :: Maybe (Image PixelRGB8))
            let go = getFrame >>= writeFrame
            loopFor 10 go
            writeFrame Nothing
       _ -> putStrLn "Couldn't read the first frame from the camera"
     cleanup

main :: IO ()
main = do args <- getArgs
          case args of
            [] -> testEncode
            [s]
              | s `elem` ["--help", "-help", "-h"] -> error usage
              | s == "cam" -> testCamera
            [vidFile] -> testDecode vidFile
            _ -> error usage
  where usage =
          unlines [ "Usage: demo [videoFile]"
                  , "  If no argument is given, a test video named "
                  , "  pulse.mov is generated."
                  , ""
                  , "  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" ]


<|start_filename|>src/Codec/FFmpeg/Probe.hsc<|end_filename|>
{-# LANGUAGE
    ForeignFunctionInterface,
    GeneralizedNewtypeDeriving
    #-}

module Codec.FFmpeg.Probe (
    -- * Files
    withAvFile, nbStreams, formatName, formatMetadata, duration,

    -- * Streams
    AvStreamT, withStream, codecContext, codecName,
    codecMediaTypeName, streamBitrate, streamMetadata,
    codec, streamImageSize,

    -- * Dictionaries
    dictFoldM_
    ) where

import Control.Applicative ( Applicative )
import Control.Monad.Catch ( MonadMask, finally )
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.Int ( Int64 )
import Foreign.C.String ( CString, peekCString, withCString )
import Foreign.C.Types ( CInt(..) )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( Ptr, nullPtr )
import Foreign.Storable

import Codec.FFmpeg.Enums
import Codec.FFmpeg.Decode
import Codec.FFmpeg.Types

#include <libavformat/avformat.h>

-------------------------------------------------------------------------------
-- avformat - level stuff
-------------------------------------------------------------------------------

newtype AvFormat m a = AvFormat { unAvFormat :: ReaderT AVFormatContext m a }
    deriving
        ( Applicative
        , Functor
        , Monad
        , MonadIO
        , MonadReader AVFormatContext
        , MonadTrans
        )

withAvFile :: (MonadMask m, MonadIO m) => String -> AvFormat m a -> m a
withAvFile fn f = do
    ectx <- runExceptT $ openFile fn
    case ectx of
        Left e    -> liftIO $ fail e
        Right ctx -> finally
            ((liftIO $ avformat_find_stream_info ctx nullPtr) >> runReaderT (unAvFormat f) ctx)
            (liftIO $ with ctx close_input)

nbStreams :: MonadIO m => AvFormat m Int
nbStreams = avToInt $ ask >>= \ctx ->
    liftIO $ (#peek AVFormatContext, nb_streams) (getPtr ctx)

formatName :: MonadIO m => AvFormat m String
formatName = ask >>= \ctx -> liftIO $
    (#peek AVFormatContext, iformat) (getPtr ctx) >>=
    (#peek AVInputFormat, name) >>=
    peekCString

duration :: MonadIO m => AvFormat m Int64
duration = ask >>= \ctx -> liftIO $ (#peek AVFormatContext, duration) (getPtr ctx)

formatMetadata :: MonadIO m => AvFormat m AVDictionary
formatMetadata = ask >>= liftIO . (#peek AVFormatContext, metadata) . getPtr

-------------------------------------------------------------------------------
-- stream - level stuff
-------------------------------------------------------------------------------

newtype AvStreamT m a = AvStreamT { unAvStreamT :: ReaderT AVStream (m) a }
    deriving
        ( Applicative
        , Functor
        , Monad
        , MonadIO
        , MonadReader AVStream
        , MonadTrans
        )

withStream :: (MonadIO m) => Int -> AvStreamT (AvFormat m) a -> AvFormat m a
withStream sid f = nbStreams >>= \ns -> if sid >= ns
    then error $ show sid ++ " >= " ++ show ns
    else do
        ctx <- ask
        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) >>=
    av_get_media_type_string >>=
    peekCString

codec :: MonadIO m => AVCodecContext -> AvStreamT m (Maybe AVCodec)
codec cctx = (liftIO . (#peek AVCodecContext, codec) . getPtr) cctx >>=
    \mc -> if mc == nullPtr
        then return Nothing
        else return $ Just $ AVCodec mc

codecName :: MonadIO m => AVCodecContext -> AvStreamT m String
codecName cctx = liftIO $ getCodecID cctx >>= avcodec_get_name >>= peekCString

streamBitrate :: MonadIO m => AVCodecContext -> AvStreamT m Int
streamBitrate cctx = liftIO $ getBitRate cctx >>= return . fromIntegral

-- |
-- Gives the (width, height) of a video stream in pixels, not accounting for the pixel aspect ratio.
streamImageSize :: MonadIO m => AVCodecContext -> AvStreamT m (Int, Int)
streamImageSize cctx = liftIO $ (,)
    <$> liftM fromIntegral (getWidth cctx)
    <*> liftM fromIntegral (getHeight cctx)

streamMetadata :: MonadIO m => AvStreamT m AVDictionary
streamMetadata = ask >>= liftIO . (#peek AVStream, metadata) . getPtr

-------------------------------------------------------------------------------
-- dictionaries
-------------------------------------------------------------------------------

dictFoldM_
    :: MonadIO m
    => ((String, String) -> m ())
    -> AVDictionary
    -> m ()
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
            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'
    in do
        -- e <- liftIO $ malloc >>= \m -> poke m nullPtr >> return m
        next nullPtr

-------------------------------------------------------------------------------
-- helpers
-------------------------------------------------------------------------------

avToInt :: Monad m => AvFormat m CInt -> AvFormat m Int
avToInt f = f >>= return . fromIntegral

-------------------------------------------------------------------------------
-- FFI imports
-------------------------------------------------------------------------------

foreign import ccall "av_get_media_type_string"
  av_get_media_type_string :: AVMediaType -> IO CString

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 ())



<|start_filename|>src/Codec/FFmpeg/Decode.hs<|end_filename|>
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards          #-}
-- | Video decoding API. Includes FFI declarations for the underlying
-- FFmpeg functions, wrappers for these functions that wrap error
-- condition checking, and high level Haskellized interfaces.
module Codec.FFmpeg.Decode where

import           Codec.FFmpeg.AudioStream
import           Codec.FFmpeg.Common
import           Codec.FFmpeg.Enums
import           Codec.FFmpeg.Scaler
import           Codec.FFmpeg.Types
import           Control.Arrow             (first)
import           Control.Monad             (void, when)
import           Control.Monad.Except
import           Control.Monad.Trans.Maybe
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.Marshal.Alloc     (alloca, free, mallocBytes)
import           Foreign.Marshal.Array     (advancePtr)
import           Foreign.Marshal.Utils     (with)
import           Foreign.Ptr
import           Foreign.Storable

-- * FFI Declarations

foreign import ccall "avformat_open_input"
  avformat_open_input :: Ptr AVFormatContext -> CString -> Ptr AVInputFormat
                      -> Ptr AVDictionary -> IO CInt

foreign import ccall "avformat_find_stream_info"
  avformat_find_stream_info :: AVFormatContext -> Ptr () -> IO CInt

foreign import ccall "av_find_best_stream"
  av_find_best_stream :: AVFormatContext -> AVMediaType -> CInt -> CInt
                      -> Ptr AVCodec -> CInt -> IO CInt

foreign import ccall "avcodec_find_decoder"
   avcodec_find_decoder :: AVCodecID -> IO AVCodec

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_malloc"
  av_malloc :: CSize -> IO (Ptr ())

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 "avformat_close_input"
  close_input :: Ptr AVFormatContext -> IO ()

foreign import ccall "av_dict_set"
  av_dict_set :: Ptr AVDictionary -> CString -> CString -> CInt -> IO CInt

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' ->
         av_dict_set d k' v' 0
  when (r < 0) $
    stringError r >>= \err ->
       error $ "av_dict_set failed("++ err ++"): "++k++" => "++v

-- * FFmpeg Decoding Interface

-- | Open the first video input device enumerated by FFMPEG.
openCamera :: (MonadIO m, MonadError String m) => String -> CameraConfig -> m AVFormatContext
openCamera cam cfg =
  wrapIOError . alloca $ \ctx ->
    withCString cam $ \cstr ->
      do avPtr <- mallocAVFormatContext
         setupCamera avPtr cam
         poke ctx avPtr
         fmt <- case format cfg of
                  Just "mjpeg" -> withCString "v4l2" av_find_input_format
                  Just f -> withCString f av_find_input_format
                  Nothing -> pure nullPtr
         r <- alloca $ \dict -> do
                setConfig dict cfg
                avformat_open_input ctx cstr fmt dict
         when (r /= 0) $
           stringError r >>= \err ->
             fail ("ffmpeg failed opening file: " ++ err)
         peek ctx
  where
    run :: (a -> IO b) -> Maybe a -> IO ()
    run _ Nothing  = return ()
    run f (Just x) = void (f x)

    setConfig :: Ptr AVDictionary -> CameraConfig -> IO ()
    setConfig dict (CameraConfig {..}) =
      do run (dictSet dict "framerate" . show) framerate
         run (\(w,h) -> dictSet dict "video_size" (show w ++ "x" ++ show h)) resolution

    setupCamera :: AVFormatContext -> String -> IO ()
    setupCamera avfc c =
      do setCamera avfc
         setFilename avfc c
         when (format cfg == Just "mjpeg") $ do
           mjpeg <- avcodec_find_decoder avCodecIdMjpeg
           setVideoCodecID avfc avCodecIdMjpeg
           av_format_set_video_codec avfc mjpeg

openInput :: (MonadIO m, MonadError String m) => InputSource -> m AVFormatContext
openInput ipt =
  case ipt of
    File fileName -> openFile fileName
    Camera cam cf -> openCamera cam cf

-- | Open an input media file.
openFile :: (MonadIO m, MonadError String m) => String -> m AVFormatContext
openFile filename =
  wrapIOError . alloca $ \ctx ->
    withCString filename $ \cstr ->
      do poke (castPtr ctx) nullPtr
         r <- avformat_open_input ctx cstr nullPtr nullPtr
         when (r /= 0) (stringError r >>= \s ->
                          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 =
  do r <- liftIO $ withCString name avcodec_find_decoder_by_name
     when (getPtr r == nullPtr)
          (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, MonadError String m) => AVFormatContext -> m ()
checkStreams ctx =
  do r <- liftIO $ avformat_find_stream_info ctx nullPtr
     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, MonadError String m)
                => AVFormatContext
                -> m (CInt, AVCodecContext, AVCodec, AVStream)
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) (fail "Couldn't find a video stream")
      cod <- peek codec
      streams <- getStreams fmt
      vidStream <- peek (advancePtr streams (fromIntegral i))
      ctx <- getCodecContext vidStream
      return (i, ctx, cod, vidStream)

findAudioStream :: (MonadIO m, MonadError String m)
                => AVFormatContext
                -> m (CInt, AVCodecContext, AVCodec, AVStream)
findAudioStream fmt = do
  wrapIOError . alloca $ \codec -> do
      poke codec (AVCodec nullPtr)
      i <- av_find_best_stream fmt avmediaTypeAudio (-1) (-1) codec 0
      when (i < 0) (fail "Couldn't find audio stream")
      cod <- peek codec
      streams <- getStreams fmt
      audioStream <- peek (advancePtr streams (fromIntegral i))
      ctx <- getCodecContext audioStream
      return (i, ctx, cod, audioStream)

-- | Find a registered decoder with a codec ID matching that found in
-- the given 'AVCodecContext'.
getDecoder :: (MonadIO m, MonadError String m)
           => AVCodecContext -> m AVCodec
getDecoder ctx = do p <- liftIO $ getCodecID ctx >>= avcodec_find_decoder
                    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, 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) (fail "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) (fail "Frame read failed")

-- | Read frames of the given 'AVPixelFormat' from a video stream.
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

-- | 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

-- | 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 ())
frameReaderTime dstFmt src =
  do inputContext <- openInput src
     checkStreams inputContext
     (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext
     _ <- openCodec ctx cod
     (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx
     AVRational num den <- liftIO $ getTimeBase vidStream
     let (numl, dend) = (fromIntegral num, fromIntegral den)
         frameTime' frame =
           do n <- getPts frame
              return $ fromIntegral (n * numl) / dend
         readTS = do frame <- reader
                     case frame of
                       Nothing -> return Nothing
                       Just f -> do t <- frameTime' f
                                    return $ Just (f, t)
     return (readTS, cleanup)

frameAudioReader :: (MonadIO m, MonadError String m)
                 => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO ())
frameAudioReader fileName = do
  inputContext <- openInput fileName
  checkStreams inputContext
  (audioStreamIndex, ctx, cod, audioStream) <- findAudioStream inputContext
  openCodec ctx cod
  as <- liftIO $ do
    bitrate <- getBitRate ctx
    samplerate <- getSampleRate ctx
    channelLayout <- getChannelLayout ctx
    sampleFormat <- getSampleFormat ctx
    channels <- getChannels ctx
    codecId <- getCodecID cod
    return $ AudioStream
        { asBitRate = bitrate
        , asSampleRate = samplerate
        , asSampleFormat = sampleFormat
        , asChannelLayout = channelLayout
        , asChannelCount = channels
        , asCodec = codecId
        }
  (readFrame, finalize) <- prepareAudioReader inputContext audioStreamIndex ctx
  return (as, readFrame, finalize)

-- | Read time stamped RGB frames with the result in the 'MaybeT'
-- transformer.
--
-- > 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

prepareAudioReader :: (MonadIO m, MonadError String m)
                   => AVFormatContext -> CInt -> AVCodecContext
                   -> m (IO (Maybe AVFrame), IO ())
prepareAudioReader fmtCtx audStream codCtx =
  wrapIOError $ do
    frame <- frame_alloc_check
    pkt <- av_packet_alloc
    let cleanup = do with frame av_frame_free
                     _ <- codec_close codCtx
                     with fmtCtx close_input
                     free (getPtr pkt)
        getFrame = do
          ret <- avcodec_receive_frame codCtx frame
          if ret < 0
            then do
              r <- av_read_frame fmtCtx pkt
              if r < 0
                then return Nothing
                else do
                  whichStream <- getStreamIndex pkt
                  if whichStream == audStream
                    then do
                      runWithError "Error sending packet" (avcodec_send_packet codCtx pkt)
                      getFrame
                    else free_packet pkt >> getFrame
            else return $ Just frame
    return (getFrame `catchError` const (return Nothing), cleanup)

-- | Construct an action that gets the next available frame, and an
-- action to release all resources associated with this video stream.
prepareReader :: (MonadIO m, MonadError String m)
              => AVFormatContext -> CInt -> AVPixelFormat -> AVCodecContext
              -> m (IO (Maybe AVFrame), IO ())
prepareReader fmtCtx vidStream dstFmt codCtx =
  wrapIOError $
  do fRaw <- frame_alloc_check
     fRgb <- frame_alloc_check

     w <- getWidth codCtx
     h <- getHeight codCtx
     fmt <- getPixelFormat codCtx

     setWidth fRgb w
     setHeight fRgb h
     setPixelFormat fRgb dstFmt

     frame_get_buffer_check fRgb 32

     sws <- swsInit (ImageInfo w h fmt) (ImageInfo w h dstFmt) swsBilinear

     pkt <- AVPacket <$> mallocBytes packetSize
     let cleanup = do with fRgb av_frame_free
                      with fRaw av_frame_free
                      _ <- codec_close codCtx
                      with fmtCtx close_input
                      free (getPtr pkt)
         getFrame = do
           read_frame_check 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
               -- Some streaming codecs require a final flush with
               -- an empty packet
               -- fin' <- alloca $ \fin2 -> do
               --           free_packet pkt
               --           (#poke AVPacket, data) pkt nullPtr
               --           (#poke AVPacket, size) pkt (0::CInt)
               --           decode_video codCtx fRaw fin2 pkt
               --           peek fin2

               _ <- swsScale sws fRaw fRgb

               -- Copy the raw frame's timestamp to the RGB frame
               getPktPts fRaw >>= setPts fRgb

               free_packet pkt
               return $ Just fRgb
             else free_packet pkt >> getFrame
           else free_packet pkt >> getFrame
     return (getFrame `catchError` const (return Nothing), cleanup)
