├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── Vagrant-README.md ├── Vagrantfile ├── default.nix ├── demo ├── AudioExtract.hs ├── AudioSin.hs ├── Main.hs ├── Raster.hs ├── Transcode.hs ├── VPlay.hs └── logoTiny.gif ├── ffmpeg-light.cabal ├── ffmpeg-ubuntu-compile.sh ├── flake.lock ├── flake.nix ├── hackagedocs.sh ├── src ├── Codec │ ├── FFmpeg.hs │ └── FFmpeg │ │ ├── AudioStream.hs │ │ ├── Common.hsc │ │ ├── Decode.hs │ │ ├── Encode.hsc │ │ ├── Enums.hsc │ │ ├── Internal │ │ ├── Debug.hsc │ │ └── Linear.hs │ │ ├── Juicy.hs │ │ ├── Probe.hsc │ │ ├── Resampler.hs │ │ ├── Scaler.hs │ │ └── Types.hsc ├── hscMacros.h └── nameCompat.h ├── stack.yaml ├── stack.yaml.lock └── vagrant-bootstrap.sh /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'ffmpeg-light.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.16 12 | # 13 | # REGENDATA ("0.16",["github","ffmpeg-light.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.2.1 32 | compilerKind: ghc 33 | compilerVersion: 9.2.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.0.2 37 | compilerKind: ghc 38 | compilerVersion: 9.0.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-8.10.7 42 | compilerKind: ghc 43 | compilerVersion: 8.10.7 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-8.8.4 47 | compilerKind: ghc 48 | compilerVersion: 8.8.4 49 | setup-method: hvr-ppa 50 | allow-failure: false 51 | - compiler: ghc-8.6.5 52 | compilerKind: ghc 53 | compilerVersion: 8.6.5 54 | setup-method: hvr-ppa 55 | allow-failure: false 56 | fail-fast: false 57 | steps: 58 | - name: apt 59 | run: | 60 | apt-get update 61 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 62 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 63 | mkdir -p "$HOME/.ghcup/bin" 64 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 65 | chmod a+x "$HOME/.ghcup/bin/ghcup" 66 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 67 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 68 | else 69 | apt-add-repository -y 'ppa:hvr/ghc' 70 | apt-get update 71 | apt-get install -y "$HCNAME" 72 | mkdir -p "$HOME/.ghcup/bin" 73 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 74 | chmod a+x "$HOME/.ghcup/bin/ghcup" 75 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 76 | fi 77 | env: 78 | HCKIND: ${{ matrix.compilerKind }} 79 | HCNAME: ${{ matrix.compiler }} 80 | HCVER: ${{ matrix.compilerVersion }} 81 | - name: Set PATH and environment variables 82 | run: | 83 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 84 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 85 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 86 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 87 | HCDIR=/opt/$HCKIND/$HCVER 88 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 89 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 90 | echo "HC=$HC" >> "$GITHUB_ENV" 91 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 92 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 93 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 94 | else 95 | HC=$HCDIR/bin/$HCKIND 96 | echo "HC=$HC" >> "$GITHUB_ENV" 97 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 98 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 99 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 100 | fi 101 | 102 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 103 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 104 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 105 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 106 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 107 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 108 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 109 | env: 110 | HCKIND: ${{ matrix.compilerKind }} 111 | HCNAME: ${{ matrix.compiler }} 112 | HCVER: ${{ matrix.compilerVersion }} 113 | - name: env 114 | run: | 115 | env 116 | - name: write cabal config 117 | run: | 118 | mkdir -p $CABAL_DIR 119 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 152 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 153 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 154 | rm -f cabal-plan.xz 155 | chmod a+x $HOME/.cabal/bin/cabal-plan 156 | cabal-plan --version 157 | - name: checkout 158 | uses: actions/checkout@v3 159 | with: 160 | path: source 161 | - name: initial cabal.project for sdist 162 | run: | 163 | touch cabal.project 164 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 165 | cat cabal.project 166 | - name: sdist 167 | run: | 168 | mkdir -p sdist 169 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 170 | - name: unpack 171 | run: | 172 | mkdir -p unpacked 173 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 174 | - name: generate cabal.project 175 | run: | 176 | PKGDIR_ffmpeg_light="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ffmpeg-light-[0-9.]*')" 177 | echo "PKGDIR_ffmpeg_light=${PKGDIR_ffmpeg_light}" >> "$GITHUB_ENV" 178 | rm -f cabal.project cabal.project.local 179 | touch cabal.project 180 | touch cabal.project.local 181 | echo "packages: ${PKGDIR_ffmpeg_light}" >> cabal.project 182 | echo "package ffmpeg-light" >> cabal.project 183 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 184 | cat >> cabal.project <> cabal.project.local 187 | cat cabal.project 188 | cat cabal.project.local 189 | - name: dump install plan 190 | run: | 191 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 192 | cabal-plan 193 | - name: restore cache 194 | uses: actions/cache/restore@v3 195 | with: 196 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 197 | path: ~/.cabal/store 198 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 199 | - name: install dependencies 200 | run: | 201 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 202 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 203 | - name: build w/o tests 204 | run: | 205 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 206 | - name: build 207 | run: | 208 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 209 | - name: cabal check 210 | run: | 211 | cd ${PKGDIR_ffmpeg_light} || false 212 | ${CABAL} -vnormal check 213 | - name: haddock 214 | run: | 215 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 216 | - name: unconstrained build 217 | run: | 218 | rm -f cabal.project.local 219 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 220 | - name: save cache 221 | uses: actions/cache/save@v3 222 | if: always() 223 | with: 224 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 225 | path: ~/.cabal/store 226 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | .cabal-sandbox 3 | dist 4 | .vagrant 5 | /buildplan 6 | /.cabal 7 | /.cabbages 8 | /TAGS 9 | .stack-work 10 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.14.0 2 | * Audio support 3 | * New demo for extracting audio from a video to a mp3 4 | * New demo with both video and audio using sinusoidal audio waves 5 | 6 | # 0.13.0 7 | * Support webcams on Linux 8 | 9 | # 0.12.2.2 10 | * Fix a video playback framerate issue in the `vplay` demo (@gelisam) 11 | 12 | # 0.12.2 13 | * Better support for ffmpeg-3.4.2 API changes 14 | 15 | # 0.12.1 16 | * Bump base upper bound 17 | * Rewritten Travis-CI support for GHC 8.02, 8.2.2, and 8.4.2 18 | 19 | # 0.12.0 20 | 21 | * Refactoring to better interoperate with SDL2 22 | * SDL2 video player demo executable 23 | 24 | [Thanks to Vladimir Pankov!] 25 | 26 | # 0.11.1 27 | 28 | * Use `Control.Monad.Except` instead of the deprecated `Control.Monad.Error` (Issue reported by Alexander / @AleXoundOS) 29 | 30 | # 0.11.0 31 | 32 | * Query stream duration (Matthias Treydte) 33 | * Initial support for verbosity control; defaults to quiet 34 | * Can be changed with the new `setLogLevel` function 35 | 36 | # 0.10. 0 37 | 38 | * Fix encoder bug that created a single black frame at the start of 39 | every video (Jonathan Daugherty) 40 | 41 | # 0.9.0 42 | 43 | * Add support for camera input (Thomas M. DuBuisson) 44 | * Try it: build the demo executable (`cabal configure -fBuildDemo`) 45 | and run `cabal run demo -- cam` to record 10s of video from a 46 | connected camera to an output file `camera.mov`. 47 | 48 | * Extract frame time stamps from the video stream rather than the 49 | codec context (hat tip to Jaro Reinders) 50 | 51 | # 0.8.2 52 | 53 | * Added probe features 54 | 55 | # 0.8.1 56 | 57 | * Update raster demo to use new JuicyPixels-3.2 API 58 | 59 | # 0.8 60 | 61 | * Update to transformers-0.4.1 and mtl-2.2.1 62 | * Changed decode-related types to accomodate deprecation of the 63 | `Error` class. This means that if you want to initialize decoders 64 | in your own transformer stack that has a `MonadError` instance, 65 | you will need to use the variants with names suffixed by a "T" 66 | (for transformer). 67 | 68 | * Update to ffmpeg 2.3 69 | 70 | * Address deprecation warning 71 | 72 | `Using AVStream.codec.time_base as a timebase hint to the muxer is 73 | deprecated. Set AVStream.time_base instead.` 74 | 75 | * Address "non-strictly-monotonic PTS" warning 76 | 77 | * Rasterific bump 78 | * Rasterific exports its own linear algebra types as of 0.3 79 | 80 | # 0.7.1 81 | 82 | * Bumped transformers dependency 83 | 84 | Note: The use of mtl still triggers deprecation warnings from 85 | transformers. 86 | 87 | * Fixed bug with changing source pixel format from RGB during 88 | encoding. 89 | 90 | * Added BGRA pixel format 91 | 92 | # 0.7 93 | 94 | * Simplified top-level API to focus on JuicyPixels-based interface 95 | 96 | # 0.6 97 | 98 | * Cleaned the API of detritus. Use the image* functions. 99 | 100 | # 0.5 101 | 102 | * Juiced the Encode and Decode APIs. 103 | 104 | Using `imageWriter` and `imageReader` provides a degree of pixel 105 | format polymorphism based on JuicyPixels pixel types. 106 | 107 | # 0.4 108 | 109 | * Fixed corrupted output of palettized animated GIFs. 110 | 111 | * Added palettization options 112 | 113 | * Using `avPixFmtRgb8` results in a small file 114 | 115 | * Using the default pixel format (`avPixFmtPal8`) results in a good-looking, 116 | fairly large file thanks to JuicyPixels's `palettize` function. 117 | 118 | * Setting the `epPreset` field of the `EncodingParams` value passed to 119 | `frameWriter` to `"dither"` results in an even prettier, even larger GIF 120 | file (again, thanks to JuicyPixels's `palettize` function). 121 | 122 | * See the `demo/Raster.hs` for examples. 123 | 124 | # 0.3.1 125 | 126 | * Automatically palettize RGB24 to RGB8 for GIF output. 127 | 128 | * Add a Rasterific demo program that records an animation. 129 | 130 | # 0.3 131 | 132 | * Support for GIF encoding (and other palletized formats). 133 | 134 | # 0.2 135 | 136 | * Separate `Scaler` module and friendly `libswscaler` interface. 137 | 138 | * Generalized `toJuicy` conversion. 139 | 140 | * Added demo program. 141 | 142 | # 0.1 143 | 144 | * Basic h264 encoding and decoding. 145 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Anthony Cowley 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Anthony Cowley nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Minimal bindings to the [FFmpeg](http://www.ffmpeg.org) library. 2 | 3 | Stream frames from an encoded video, or stream frames to a video output file. To read the first frame from an `h264`-encoded file into a [`JuicyPixels`](http://hackage.haskell.org/package/JuicyPixels) `Maybe DynamicImage`, 4 | 5 | ```haskell 6 | import Codec.FFmpeg 7 | import Codec.Picture 8 | import Control.Applicative 9 | 10 | go :: IO (Maybe DynamicImage) 11 | go = do initFFmpeg 12 | (getFrame, cleanup) <- imageReader (File "myVideo.mov") 13 | (fmap ImageRGB8 <$> getFrame) <* cleanup 14 | ``` 15 | 16 | A demonstration of creating an animation using the 17 | [`Rasterific`](http://hackage.haskell.org/package/Rasterific) library 18 | may be found in 19 | [`demo/Raster.hs`](https://github.com/acowley/ffmpeg-light/blob/master/demo/Raster.hs). A 20 | weird animated variation of the `Rasterific` logo is the result: 21 | 22 | ![Animated Rasterific Logo](https://github.com/acowley/ffmpeg-light/raw/master/demo/logoTiny.gif) 23 | 24 | Note that encoding an animation to a modern video codec like h264 can 25 | result in even smaller files. But those files can't be embedded in a 26 | README on github. 27 | 28 | Tested on OS X 10.9.2 with FFmpeg 2.2.1 installed via [homebrew](http://brew.sh). 29 | 30 | Debian and Ubuntu users: Your package manager's `ffmpeg` package is actually a not-quite-compatible fork of the `ffmpeg` project. To use `ffmpeg-light`, run the included `ffmpeg-ubuntu-compile.sh` script as regular (non-root) user. This builds the ffmpeg libraries locally. Configure your projects that depend on `ffmpeg-light` with a modified `PKG_CONFIG_PATH`: 31 | 32 | ```bash 33 | PKG_CONFIG_PATH="$HOME/ffmpeg_build/lib/pkgconfig" cabal configure --disable-shared my-project 34 | ``` 35 | 36 | There are signs that the next Ubuntu release will come with the original `ffmpeg` and development packages. 37 | 38 | [![Build Status](https://github.com/acowley/ffmpeg-light/workflows/CI/badge.svg)](https://github.com/acowley/ffmpeg-light/actions) 39 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Vagrant-README.md: -------------------------------------------------------------------------------- 1 | Getting FFmpeg installed can be tricky, so a [Vagrant](www.vagrantup.com) environment description is provided for working with ffmpeg-light in a Ubuntu 14.04 VM. After you've installed `vagrant` (and perhaps [VirtualBox](https://www.virtualbox.org) if that is how you are provisioning the VM), the following steps will get you started with GHC in a fresh VM. The terminal session shown below uses `host$` to indicate the prompt on your host machine, and `vagrant$` to indicate the prompt in the Vagrant VM. 2 | 3 | - Change into the ffmpeg-light directory with the `Vagrantfile` 4 | - `host$ vagrant init ubuntu/trusty64` 5 | - `host$ vagrant up` 6 | - `host$ vagrant ssh` 7 | - `vagrant$ sh /vagrant/ffmpeg-ubuntu-compile.sh` 8 | - `vagrant$ cabal run demo` 9 | 10 | You can copy the video file produced by `cabal run demo` onto your host system by running, `cd pulse.mov /vagrant/linux-pulse.mov` to verify that everything worked. 11 | -------------------------------------------------------------------------------- /Vagrantfile: -------------------------------------------------------------------------------- 1 | # -*- mode: ruby -*- 2 | # vi: set ft=ruby : 3 | 4 | # Vagrantfile API/syntax version. Don't touch unless you know what you're doing! 5 | VAGRANTFILE_API_VERSION = "2" 6 | 7 | Vagrant.configure(VAGRANTFILE_API_VERSION) do |config| 8 | # All Vagrant configuration is done here. The most common configuration 9 | # options are documented and commented below. For a complete reference, 10 | # please see the online documentation at vagrantup.com. 11 | 12 | # Every Vagrant virtual environment requires a box to build off of. 13 | config.vm.box = "ubuntu/trusty64" 14 | 15 | # Disable automatic box update checking. If you disable this, then 16 | # boxes will only be checked for updates when the user runs 17 | # `vagrant box outdated`. This is not recommended. 18 | # config.vm.box_check_update = false 19 | 20 | # Create a forwarded port mapping which allows access to a specific port 21 | # within the machine from a port on the host machine. In the example below, 22 | # accessing "localhost:8080" will access port 80 on the guest machine. 23 | # config.vm.network "forwarded_port", guest: 80, host: 8080 24 | 25 | # Create a private network, which allows host-only access to the machine 26 | # using a specific IP. 27 | # config.vm.network "private_network", ip: "192.168.33.10" 28 | 29 | # Create a public network, which generally matched to bridged network. 30 | # Bridged networks make the machine appear as another physical device on 31 | # your network. 32 | # config.vm.network "public_network" 33 | 34 | # If true, then any SSH connections made will enable agent forwarding. 35 | # Default value: false 36 | # config.ssh.forward_agent = true 37 | 38 | # Share an additional folder to the guest VM. The first argument is 39 | # the path on the host to the actual folder. The second argument is 40 | # the path on the guest to mount the folder. And the optional third 41 | # argument is a set of non-required options. 42 | # config.vm.synced_folder "../data", "/vagrant_data" 43 | 44 | # Provider-specific configuration so you can fine-tune various 45 | # backing providers for Vagrant. These expose provider-specific options. 46 | # Example for VirtualBox: 47 | # 48 | # config.vm.provider "virtualbox" do |vb| 49 | # # Don't boot with headless mode 50 | # vb.gui = true 51 | # 52 | # # Use VBoxManage to customize the VM. For example to change memory: 53 | # vb.customize ["modifyvm", :id, "--memory", "1024"] 54 | # end 55 | # 56 | # View the documentation for the provider you're using for more 57 | # information on available options. 58 | config.vm.provider "virtualbox" do |vb| 59 | vb.customize ["modifyvm", :id, "--memory", "1024"] 60 | end 61 | 62 | # Enable provisioning with CFEngine. CFEngine Community packages are 63 | # automatically installed. For example, configure the host as a 64 | # policy server and optionally a policy file to run: 65 | # 66 | # config.vm.provision "cfengine" do |cf| 67 | # cf.am_policy_hub = true 68 | # # cf.run_file = "motd.cf" 69 | # end 70 | # 71 | # You can also configure and bootstrap a client to an existing 72 | # policy server: 73 | # 74 | # config.vm.provision "cfengine" do |cf| 75 | # cf.policy_server_address = "10.0.2.15" 76 | # end 77 | 78 | # Enable provisioning with Puppet stand alone. Puppet manifests 79 | # are contained in a directory path relative to this Vagrantfile. 80 | # You will need to create the manifests directory and a manifest in 81 | # the file default.pp in the manifests_path directory. 82 | # 83 | # config.vm.provision "puppet" do |puppet| 84 | # puppet.manifests_path = "manifests" 85 | # puppet.manifest_file = "default.pp" 86 | # end 87 | 88 | # Enable provisioning with chef solo, specifying a cookbooks path, roles 89 | # path, and data_bags path (all relative to this Vagrantfile), and adding 90 | # some recipes and/or roles. 91 | # 92 | # config.vm.provision "chef_solo" do |chef| 93 | # chef.cookbooks_path = "../my-recipes/cookbooks" 94 | # chef.roles_path = "../my-recipes/roles" 95 | # chef.data_bags_path = "../my-recipes/data_bags" 96 | # chef.add_recipe "mysql" 97 | # chef.add_role "web" 98 | # 99 | # # You may also specify custom JSON attributes: 100 | # chef.json = { mysql_password: "foo" } 101 | # end 102 | 103 | # Enable provisioning with chef server, specifying the chef server URL, 104 | # and the path to the validation key (relative to this Vagrantfile). 105 | # 106 | # The Opscode Platform uses HTTPS. Substitute your organization for 107 | # ORGNAME in the URL and validation key. 108 | # 109 | # If you have your own Chef Server, use the appropriate URL, which may be 110 | # HTTP instead of HTTPS depending on your configuration. Also change the 111 | # validation key to validation.pem. 112 | # 113 | # config.vm.provision "chef_client" do |chef| 114 | # chef.chef_server_url = "https://api.opscode.com/organizations/ORGNAME" 115 | # chef.validation_key_path = "ORGNAME-validator.pem" 116 | # end 117 | # 118 | # If you're using the Opscode platform, your validator client is 119 | # ORGNAME-validator, replacing ORGNAME with your organization name. 120 | # 121 | # If you have your own Chef Server, the default validation client name is 122 | # chef-validator, unless you changed the configuration. 123 | # 124 | # chef.validation_client_name = "ORGNAME-validator" 125 | config.vm.provision :shell, path: "vagrant-bootstrap.sh" 126 | end 127 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, nix-filter, base, bytestring, either, exceptions, ffmpeg 2 | , JuicyPixels, lib, monad-loops, mtl, Rasterific, sdl2 3 | , stm, text, time, transformers, vector 4 | }: 5 | mkDerivation { 6 | pname = "ffmpeg-light"; 7 | version = "0.14.1"; 8 | src = nix-filter { 9 | root = ./.; 10 | include = [ 11 | "./CHANGELOG.md" 12 | "demo" 13 | "./ffmpeg-light.cabal" 14 | "./LICENSE" 15 | "./README.md" 16 | "./Setup.hs" 17 | "./stack.yaml" 18 | "src" 19 | (nix-filter.inDirectory "src") 20 | (nix-filter.inDirectory "demo") 21 | ]; 22 | }; 23 | configureFlags = [ 24 | "-fbuildaudioextractdemo" "-fbuildaudiosindemo" "-fbuilddemo" 25 | "-fbuildrasterdemo" "-fbuildtranscodedemo" "-fbuildvplaydemo" 26 | ]; 27 | isLibrary = true; 28 | isExecutable = true; 29 | libraryHaskellDepends = [ 30 | base bytestring either exceptions JuicyPixels mtl stm transformers 31 | vector 32 | ]; 33 | libraryPkgconfigDepends = [ ffmpeg ]; 34 | executableHaskellDepends = [ 35 | base bytestring JuicyPixels monad-loops mtl Rasterific sdl2 text 36 | time transformers vector 37 | ]; 38 | homepage = "http://github.com/acowley/ffmpeg-light"; 39 | description = "Minimal bindings to the FFmpeg library"; 40 | license = lib.licenses.bsd3; 41 | } 42 | -------------------------------------------------------------------------------- /demo/AudioExtract.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Codec.FFmpeg 4 | import Codec.FFmpeg.AudioStream 5 | import Codec.FFmpeg.Decode 6 | import Codec.FFmpeg.Encode 7 | import Codec.FFmpeg.Resampler 8 | import Control.Monad.Except 9 | import System.Environment 10 | 11 | 12 | main :: IO () 13 | main = do initFFmpeg 14 | args <- getArgs 15 | 16 | case args of 17 | [fname, outname] -> do 18 | eRes <- runExceptT $ frameAudioReader (File fname) 19 | case eRes of 20 | Left er -> error er 21 | Right (as, getFrame, cleanup) -> do 22 | putStrLn $ "bitrate : " ++ show (asBitRate as) 23 | putStrLn $ "sample rate : " ++ show (asSampleRate as) 24 | putStrLn $ "sample format : " ++ 25 | show (getSampleFormatInt (asSampleFormat as)) 26 | putStrLn $ "channel layout : " ++ show (asChannelLayout as) 27 | putStrLn $ "channel count : " ++ show (asChannelCount as) 28 | let inParams = AudioParams 29 | { apChannelLayout = asChannelLayout as 30 | , apSampleRate = asSampleRate as 31 | , apSampleFormat = asSampleFormat as 32 | } 33 | outParams = AudioParams 34 | { apChannelLayout = asChannelLayout as 35 | , apSampleRate = 44100 36 | , apSampleFormat = asSampleFormat as 37 | } 38 | encParams = AEncodingParams 39 | { aepChannelLayout = apChannelLayout outParams 40 | , aepSampleRate = apSampleRate outParams 41 | , aepSampleFormat = apSampleFormat outParams 42 | , aepPreset = "" 43 | , aepFormatName = Nothing 44 | } 45 | (mCtx, audWriter) <- audioWriter encParams outname 46 | case mCtx of 47 | Nothing -> error "Didn't get audio context" 48 | Just ctx -> do 49 | (sendFrame, getResampledFrame) <- makeResampler ctx inParams outParams 50 | let go :: Int -> IO () 51 | go i = do 52 | mFrame <- getFrame 53 | case mFrame of 54 | Nothing -> readAndWrite 55 | Just frame -> do 56 | sendFrame frame 57 | readAndWrite 58 | go (i+1) 59 | readAndWrite = do 60 | mFrame <- getResampledFrame 61 | case mFrame of 62 | Nothing -> return () 63 | Just frame -> do 64 | audWriter (Just frame) 65 | readAndWrite 66 | go 1 67 | audWriter Nothing 68 | 69 | cleanup 70 | return () 71 | return () 72 | _ -> putStrLn usage 73 | where 74 | usage = "Supply an input video and output filename to extract the audio file to a mp3 file" 75 | -------------------------------------------------------------------------------- /demo/AudioSin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | module Main where 3 | 4 | import Codec.FFmpeg 5 | import Codec.FFmpeg.AudioStream 6 | import Codec.FFmpeg.Common 7 | import Codec.FFmpeg.Encode 8 | import Codec.FFmpeg.Enums 9 | import Codec.FFmpeg.Juicy 10 | import Codec.FFmpeg.Types 11 | import Codec.Picture 12 | import Control.Monad.Except 13 | import Data.IORef 14 | import Foreign.C.Types 15 | import Foreign.Marshal.Array 16 | import Foreign.Ptr 17 | import Foreign.Storable 18 | import System.Environment 19 | 20 | -- Simple Music DSL 21 | type Sound = Float -> Float 22 | 23 | volume :: Float -> Sound -> Sound 24 | volume v s t = v * (s t) 25 | 26 | mkNote :: Float -> Sound 27 | mkNote f = \t -> sin (f * 2 * pi * t) 28 | 29 | a4 :: Sound 30 | a4 = mkNote 440 31 | 32 | c4 :: Sound 33 | c4 = mkNote 261.6256 34 | 35 | d4 :: Sound 36 | d4 = mkNote 293.6648 37 | 38 | e4 :: Sound 39 | e4 = mkNote 329.6276 40 | 41 | f4 :: Sound 42 | f4 = mkNote 349.2282 43 | 44 | g4 :: Sound 45 | g4 = mkNote 391.9954 46 | 47 | b4 :: Sound 48 | b4 = mkNote 493.8833 49 | 50 | c5 :: Sound 51 | c5 = mkNote 523.2511 52 | 53 | e5 :: Sound 54 | e5 = mkNote 659.2551 55 | 56 | combineSounds :: [Sound] -> Sound 57 | combineSounds snds t = sum $ map (\s -> s t) snds 58 | 59 | -- Take sounds and their duration and put them in order 60 | sequenceSounds :: [(Float, Sound)] -> Sound 61 | sequenceSounds snds tin = go tin snds 62 | where 63 | go t [(_,snd)] = snd t 64 | go t ((dur,snd):rest) 65 | | t <= dur = snd t 66 | | otherwise = go (t-dur) rest 67 | go _ _ = 0 68 | 69 | cMaj7 = combineSounds [ volume 0.23 c4, volume 0.23 e4, volume 0.23 g4, volume 0.23 b4 ] 70 | dMin7 = combineSounds [ volume 0.23 d4, volume 0.23 f4, volume 0.23 a4, volume 0.23 c5 ] 71 | g7 = combineSounds [ volume 0.23 g4, volume 0.23 a4, volume 0.23 c5, volume 0.23 e5 ] 72 | -- ii - V7 - I jazz chord progression 73 | twoFiveOne = sequenceSounds [(1, dMin7), (1, g7), (1, cMaj7)] 74 | 75 | mkImage :: Int -> Int -> PixelRGB8 -> Image PixelRGB8 76 | mkImage w h color = 77 | generateImage (\_ _ -> color) w h 78 | 79 | main :: IO () 80 | main = do 81 | initFFmpeg 82 | 83 | let w = 1080 84 | h = 720 85 | encParams = AVEncodingParams 86 | { avepWidth = w 87 | , avepHeight = h 88 | , avepFps = 30 89 | , avepCodec = Nothing 90 | , avepPixelFormat = Nothing 91 | , avepChannelLayout = avChLayoutMono 92 | , avepSampleRate = 44100 93 | , avepSampleFormat = avSampleFmtFltp 94 | , avepPreset = "" 95 | , avepFormatName = Nothing 96 | } 97 | writerContext <- audioVideoWriter encParams "sinusoidal.mp4" 98 | let mCtx = avwAudioCodecContext writerContext 99 | videoWriter = avwVideoWriter writerContext 100 | audioWriter = avwAudioWriter writerContext 101 | case mCtx of 102 | Nothing -> error "Could not get audio ctx" 103 | Just ctx -> do 104 | frame <- frame_alloc_check 105 | setNumSamples frame =<< getFrameSize ctx 106 | setFormat frame . getSampleFormatInt =<< getSampleFormat ctx 107 | setChannelLayout frame =<< getChannelLayout ctx 108 | setSampleRate frame =<< getSampleRate ctx 109 | 110 | ch <- getChannelLayout ctx 111 | numChannels <- getChannels ctx 112 | 113 | print ("Channel Layout", ch) 114 | print ("Channels", numChannels) 115 | 116 | runWithError "Alloc buffers" (av_frame_get_buffer frame 0) 117 | 118 | let sampleRate = avepSampleRate encParams 119 | print ("sample rate", sampleRate) 120 | 121 | vidFrameRef <- newIORef 0 :: IO (IORef Int) 122 | forM_ [0..120] $ \i -> do 123 | av_frame_make_writable frame 124 | dataPtr <- castPtr <$> getData frame :: IO (Ptr CFloat) 125 | nbSamples <- getNumSamples frame 126 | forM_ [0..nbSamples-1] $ \j -> do 127 | let idx = fromIntegral i * fromIntegral nbSamples + fromIntegral j :: Integer 128 | t = fromIntegral idx / fromIntegral sampleRate 129 | v = twoFiveOne t 130 | poke (advancePtr dataPtr (fromIntegral j)) (realToFrac v) 131 | vidFrame <- readIORef vidFrameRef 132 | when (t * 30 >= fromIntegral vidFrame) $ do 133 | -- TODO: I'm not sure why t seems to be half the actual value but I need to do 134 | -- 0.5 and 1 to make the chord changes match up with the color changes 135 | modifyIORef vidFrameRef (+1) 136 | let color = if | t <= 1 -> PixelRGB8 255 0 0 137 | | t <= 2 -> PixelRGB8 0 255 0 138 | | otherwise -> PixelRGB8 0 0 255 139 | img = mkImage (fromIntegral w) (fromIntegral h) color 140 | videoWriter (Just (fromJuciy img)) 141 | audioWriter (Just frame) 142 | 143 | videoWriter Nothing 144 | audioWriter Nothing 145 | -------------------------------------------------------------------------------- /demo/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Codec.FFmpeg 3 | import Codec.Picture 4 | import Control.Monad (replicateM_) 5 | import qualified Data.Time.Clock as C 6 | import qualified Data.Vector.Storable as V 7 | import System.Environment 8 | import qualified System.Info as Info 9 | import Control.Monad (unless) 10 | 11 | -- The example used in the README 12 | firstFrame :: IO (Maybe DynamicImage) 13 | firstFrame = do initFFmpeg 14 | (getFrame, cleanup) <- imageReader (File "myVideo.mov") 15 | (fmap ImageRGB8 <$> getFrame) <* cleanup 16 | 17 | -- | Generate a video that pulses from light to dark. 18 | pulseVid :: IO () 19 | pulseVid = 20 | do boom <- imageWriter (defaultParams sz sz) "pulse.mov" 21 | let boom' = (boom :: Maybe (Image Pixel8) -> IO ()) . Just . Image sz sz 22 | go :: Int -> Int -> Int -> IO () 23 | go 600 _ _ = boom Nothing 24 | go n d i = do boom' $ V.replicate (sz*sz) (fromIntegral i) 25 | let i' = i + d 26 | if i' < 100 27 | then go (n+1) 1 101 28 | else if i' > 255 29 | then go (n+1) (-1) 254 30 | else go (n+1) d i' 31 | go 0 (-1) 255 32 | where sz :: Integral a => a 33 | sz = 64 34 | 35 | -- | Generate a video that fades from white to gray to white. 36 | testEncode :: IO () 37 | testEncode = initFFmpeg >> pulseVid >> putStrLn "All done!" 38 | 39 | -- | Decoding example. Try changing 'ImageRGB8' to 'ImageY8' in the 40 | -- 'savePngImage' lines to automatically decode to grayscale images! 41 | testDecode :: FilePath -> IO () 42 | testDecode vidFile = 43 | do initFFmpeg 44 | (getFrame, cleanup) <- imageReaderTime (File vidFile) 45 | frame1 <- getFrame 46 | case frame1 of 47 | Just (avf,ts) -> do putStrLn $ "Frame at "++show ts 48 | savePngImage "frame1.png" (ImageRGB8 avf) 49 | Nothing -> putStrLn "No frame for me :(" 50 | replicateM_ 299 getFrame 51 | frame2 <- getFrame 52 | case frame2 of 53 | Just (avf,ts) -> do putStrLn $ "Frame at "++show ts 54 | savePngImage "frame2.png" (ImageRGB8 avf) 55 | Nothing -> putStrLn "No frame for me :(" 56 | cleanup 57 | putStrLn "All done!" 58 | 59 | -- | @loopFor timeSpan action@ repeats @action@ until at least @timeSpan@ 60 | -- seconds have elapsed. 61 | loopFor :: Double -> IO () -> IO () 62 | loopFor time m = 63 | do start <- C.getCurrentTime 64 | let go = do m 65 | now <- C.getCurrentTime 66 | unless (realToFrac (C.diffUTCTime now start) >= time) go 67 | go 68 | 69 | testCamera :: IO () 70 | testCamera = 71 | do initFFmpeg -- Defaults to quiet (minimal) logging 72 | -- setLogLevel avLogInfo -- Restore standard ffmpeg logging 73 | 74 | (getFrame, cleanup) <- imageReader $ 75 | case Info.os of 76 | "linux" -> 77 | let cfg = CameraConfig (Just 30) Nothing (Just "mjpeg") 78 | -- (Just "v4l2") 79 | in Camera "/dev/video0" cfg 80 | "darwin" -> Camera "0:0" defaultCameraConfig 81 | _ -> error "Unsure how to identify a default camera input" 82 | 83 | frame1 <- getFrame 84 | case frame1 of 85 | img@(Just (Image w h _)) -> 86 | do let [w',h'] = map fromIntegral [w,h] 87 | writeFrame <- imageWriter (defaultParams w' h') "camera.mov" 88 | writeFrame (img :: Maybe (Image PixelRGB8)) 89 | let go = getFrame >>= writeFrame 90 | loopFor 10 go 91 | writeFrame Nothing 92 | _ -> putStrLn "Couldn't read the first frame from the camera" 93 | cleanup 94 | 95 | main :: IO () 96 | main = do args <- getArgs 97 | case args of 98 | [] -> testEncode 99 | [s] 100 | | s `elem` ["--help", "-help", "-h"] -> error usage 101 | | s == "cam" -> testCamera 102 | [vidFile] -> testDecode vidFile 103 | _ -> error usage 104 | where usage = 105 | unlines [ "Usage: demo [videoFile]" 106 | , " If no argument is given, a test video named " 107 | , " pulse.mov is generated." 108 | , "" 109 | , " If a file name is given, then two frames are " 110 | , " extracted: the first frame, and the 301st." 111 | , " These are saved to frame1.png and frame2.png" ] 112 | -------------------------------------------------------------------------------- /demo/Raster.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Codec.FFmpeg 3 | import Codec.Picture 4 | -- import Codec.Picture.Types (dropTransparency) 5 | import Control.Monad (forM_) 6 | import Graphics.Rasterific 7 | import Graphics.Rasterific.Linear 8 | import Graphics.Rasterific.Texture 9 | import Graphics.Rasterific.Transformations 10 | 11 | -- | The Rasterific logo sample shape. 12 | logo :: Int -> Bool -> Vector -> [Primitive] 13 | logo size inv offset = map BezierPrim . bezierFromPath . way $ map (^+^ offset) 14 | [ (V2 0 is) 15 | , (V2 0 0) 16 | , (V2 is 0) 17 | , (V2 is2 0) 18 | , (V2 is2 is) 19 | , (V2 is2 is2) 20 | , (V2 is is2) 21 | , (V2 0 is2) 22 | , (V2 0 is) 23 | ] 24 | where is = fromIntegral size 25 | is2 = is + is 26 | 27 | way | inv = reverse 28 | | otherwise = id 29 | 30 | -- | Sample a quadratic bezier curve. 31 | bezierInterp :: Bezier -> [Point] 32 | bezierInterp (Bezier a b c) = go 0 33 | where v1 = b - a 34 | v2 = c - b 35 | go t 36 | | t >= 1 = [] 37 | | otherwise = let q0 = a + v1 ^* t 38 | q1 = b + v2 ^* t 39 | vq = q1 - q0 40 | in q0 + vq ^* t : (go $! t + 0.05) 41 | 42 | -- | Our animation path. 43 | path :: [Point] 44 | path = concatMap bezierInterp $ 45 | bezierFromPath [ (V2 0 is) 46 | , (V2 0 0) 47 | , (V2 (is+5) 0) 48 | , (V2 (is2+10) 0) 49 | , (V2 (is2+10) is) 50 | , (V2 (is2+10) is2) 51 | , (V2 (is+5) is2) 52 | , (V2 0 is2) 53 | , (V2 0 is) 54 | ] 55 | where is = 15 56 | is2 = is + is 57 | 58 | background, blue :: PixelRGBA8 59 | background = PixelRGBA8 128 128 128 255 60 | blue = PixelRGBA8 0 020 150 255 61 | 62 | -- `fgSize` will determine our image size. `bgSize` is smaller so we 63 | -- see the effect of the `SamplerRepeat` sampler. 64 | 65 | fgSize, fgScale, bgSize :: Float 66 | fgSize = 350 67 | fgScale = fgSize / 100 68 | bgSize = 57 * fgScale 69 | 70 | fgSizei :: Integral a => a 71 | fgSizei = floor fgSize 72 | 73 | -- | A ring with a drop-shadow on the inside. The texture is repeated, 74 | -- resulting in concentric rings centered at @(200,200)@. 75 | bgGrad :: Texture PixelRGBA8 76 | bgGrad = withSampler SamplerRepeat $ 77 | radialGradientTexture gradDef (V2 bgSize bgSize) (bgSize * 0.5) 78 | where gradDef = [(0 , PixelRGBA8 255 255 255 255) 79 | ,(0.5, PixelRGBA8 255 255 255 255) 80 | ,(0.5, PixelRGBA8 255 255 255 255) 81 | ,(0.525, PixelRGBA8 255 255 255 255) 82 | ,(0.675, PixelRGBA8 128 128 128 255) 83 | ,(0.75, PixelRGBA8 100 149 237 255) 84 | ,(1, PixelRGBA8 100 149 237 255) 85 | ] 86 | 87 | -- | Adapted from the Rasterific logo example. 88 | logoTest :: Texture PixelRGBA8 -> Vector -> Image PixelRGBA8 89 | logoTest texture insetOrigin = 90 | renderDrawing fgSizei fgSizei background (bg >> drawing) 91 | where 92 | beziers = logo 40 False $ V2 10 10 93 | inverse = logo 20 True $ (V2 20 20 + insetOrigin) 94 | bg = withTexture bgGrad . fill $ rectangle (V2 0 0) fgSize fgSize 95 | drawing = withTexture texture . fill 96 | . transform (applyTransformation $ scale fgScale fgScale) 97 | $ beziers ++ inverse 98 | 99 | -- | Animate the logo and write it to a video file! 100 | main :: IO () 101 | main = do initFFmpeg 102 | -- Change the output file extension to ".gif" and drop 103 | -- transparency to get an animated gif! We can get a small 104 | -- GIF file by setting 'epPixelFormat' to 'avPixFmtRgb8', 105 | -- but it might not look very good. 106 | 107 | w <- imageWriter params "logo.mov" 108 | -- w <- (. fmap (pixelMap dropTransparency)) 109 | -- `fmap` imageWriter params "logo.gif" 110 | 111 | forM_ path $ w . Just . logoTest (uniformTexture blue) 112 | w Nothing 113 | where params = defaultParams fgSizei fgSizei 114 | -- tinyGif = params { epPixelFormat = Just avPixFmtRgb8 } 115 | -- prettyGif = params { epPreset = "dither" } 116 | -------------------------------------------------------------------------------- /demo/Transcode.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment (getArgs) 4 | import qualified Codec.FFmpeg as FF 5 | import qualified Codec.FFmpeg.Encode as FF 6 | import Codec.Picture 7 | 8 | type Frame = Image PixelRGB8 9 | 10 | usage :: String 11 | usage = 12 | unlines [ "Usage: transcode inputFile outputFile [outputFormat] [outputWidth] [outputHeight]" 13 | , " Example: transcode rtmp://localhost/app/one rtmp://localhost/app/two flv 640 480" 14 | , "" 15 | , " Copies the content from inputFile to outputFile using H264." 16 | , " Defaults:" 17 | , " outputFormat=flv" 18 | , " outputWidth=640" 19 | , " outputHeight=480" 20 | ] 21 | 22 | main :: IO () 23 | main = do 24 | args <- getArgs 25 | FF.initFFmpeg 26 | FF.setLogLevel FF.avLogDebug 27 | case args of 28 | [from, to] -> copy from to "flv" 640 480 29 | [from, to, format, w, h] -> copy from to format (read w) (read h) 30 | _ -> error usage 31 | 32 | copy :: FilePath -> FilePath -> String -> Int -> Int -> IO () 33 | copy from to format w h = do 34 | let ep = (FF.defaultH264 (fromIntegral w) (fromIntegral h)) 35 | -- { FF.epFormatName = Just format } 36 | -- TODO: get this working again 37 | (getFrame, cleanup) <- FF.imageReader (FF.File from) 38 | putFrame <- FF.imageWriter ep to 39 | loop getFrame cleanup putFrame (\x -> return x) 40 | 41 | loop :: IO (Maybe Frame) 42 | -> IO cleanup 43 | -> (Maybe Frame -> IO ()) 44 | -> (Frame -> IO Frame) 45 | -> IO cleanup 46 | loop getFrame finishReading putFrame editFrame = do 47 | maybeFrame <- getFrame 48 | case maybeFrame of 49 | Nothing -> do 50 | putFrame Nothing 51 | finishReading 52 | Just x -> do 53 | x' <- editFrame x 54 | putFrame (Just x') 55 | loop getFrame finishReading putFrame editFrame 56 | -------------------------------------------------------------------------------- /demo/VPlay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Codec.FFmpeg 6 | import Codec.FFmpeg.Common 7 | import Codec.FFmpeg.Decode hiding (av_malloc) 8 | 9 | import Control.Concurrent.MVar (newMVar, takeMVar, putMVar) 10 | import Control.Monad.IO.Class (MonadIO) 11 | import Control.Monad.Except 12 | import Control.Monad.Loops 13 | import Control.Monad.Trans.Maybe 14 | 15 | import Data.ByteString (ByteString) 16 | import Data.ByteString.Unsafe (unsafePackCStringFinalizer) 17 | import Data.Text (Text) 18 | 19 | import Data.IORef 20 | 21 | import Foreign.C.Types 22 | import Foreign.Ptr 23 | 24 | import System.Environment 25 | 26 | import qualified SDL as SDL 27 | 28 | 29 | {- Auxiliary. -} 30 | 31 | -- Prepare input source: open, check for streams. 32 | prepareInput :: (MonadIO m, MonadError String m) 33 | => InputSource 34 | -> m AVFormatContext 35 | prepareInput inp = 36 | openInput inp >>= \ ctx -> checkStreams ctx >> return ctx 37 | 38 | -- Prepare video codec: find video stream, open. 39 | prepareVideoCodec :: (MonadIO m, MonadError String m) 40 | => AVFormatContext 41 | -> m ( CInt 42 | , AVCodecContext 43 | , AVCodec 44 | , AVStream 45 | , AVDictionary ) 46 | prepareVideoCodec inpCtx = do 47 | (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inpCtx 48 | dict <- openCodec ctx cod 49 | return (vidStreamIndex, ctx, cod, vidStream, dict) 50 | 51 | -- Transform reader to return timestamp too. 52 | readTS :: (HasPts f, Fractional t) 53 | => AVRational 54 | -> IO (Maybe f) 55 | -> IO (Maybe (f, t)) 56 | readTS (AVRational num den) reader = 57 | -- It's part of frameReaderTime definition. 58 | let (numl, dend) = (fromIntegral num, fromIntegral den) 59 | frameTime' frame = 60 | do n <- getPts frame 61 | return $ fromIntegral (n * numl) / dend 62 | reader' = do frame <- reader 63 | case frame of 64 | Nothing -> return Nothing 65 | Just f -> do t <- frameTime' f 66 | return $ Just (f, t) in reader' 67 | 68 | -- Transform frame and timestamp reader to compute frame 69 | -- time as a difference between adjacent timestamps. 70 | readTSDiff :: (MonadIO m, MonadIO m', Num t) 71 | => m' (Maybe (f, t)) -> m (m' (Maybe (f, t))) 72 | readTSDiff readerTS = do 73 | timeVar <- liftIO $ newMVar 0 74 | let reader = runMaybeT $ do 75 | (f, currTime) <- MaybeT readerTS 76 | prevTime <- takeTime 77 | putTime currTime 78 | let timeDiff = currTime - prevTime 79 | return (f, timeDiff) 80 | where 81 | takeTime = liftIO . takeMVar $ timeVar 82 | putTime = liftIO . putMVar timeVar 83 | return reader 84 | 85 | -- Transformer version of updateTextureByFrame. 86 | updateTextureByFrameT :: SDL.Texture -> AVFrame -> MaybeT IO SDL.Texture 87 | updateTextureByFrameT texture frame = 88 | copyImageDataT frame >>= updateTexture texture 89 | where 90 | updateTexture t img = 91 | frameLineSizeT frame >>= 92 | SDL.updateTexture t Nothing img 93 | 94 | -- Update texture by image data from frame. 95 | updateTextureByFrame :: SDL.Texture -> AVFrame -> IO (Maybe SDL.Texture) 96 | updateTextureByFrame t = runMaybeT . updateTextureByFrameT t 97 | 98 | -- Return Nothing when condition holds. 99 | nothingWhen 100 | :: Monad m 101 | => m a -> (a -> Bool) -> m (Maybe b) -> m (Maybe b) 102 | nothingWhen g p action = do 103 | -- Generate conditional. 104 | a <- g 105 | -- Check predicate. 106 | if p a 107 | then return Nothing 108 | else action 109 | 110 | -- Retrun Nothing when QuitEvent is received. 111 | nothingOnQuit 112 | :: MonadIO m 113 | => m (Maybe a) -> m (Maybe a) 114 | nothingOnQuit action = 115 | nothingWhen 116 | SDL.pollEvents 117 | (not . null . filter 118 | (\ event -> 119 | case SDL.eventPayload event of 120 | SDL.QuitEvent -> True 121 | SDL.KeyboardEvent ev -> 122 | SDL.keysymKeycode (SDL.keyboardEventKeysym ev) == SDL.KeycodeEscape 123 | _ -> False)) action 124 | 125 | {- Return ByteString filled by image data from frame. 126 | 127 | Returned ByteString doesn't refer back to it's 128 | source AVFrame. So, source frame may be deleted 129 | or changed, but image will stay. 130 | 131 | -} 132 | copyImageData :: AVFrame -> IO (Maybe ByteString) 133 | copyImageData frame = 134 | runMaybeT $ do 135 | 136 | -- Get required size of buffer to hold image data. 137 | imageBufSize <- frameBufferSizeT frame 138 | 139 | -- Allocate buffer to hold image data. 140 | imageBuf <- MaybeT $ 141 | Just <$> (av_malloc $ fromIntegral imageBufSize) 142 | 143 | -- Image data buffer cleanup. 144 | let imageBufCleanup = av_free imageBuf 145 | 146 | -- Copy image to buffer. 147 | _ <- frameCopyToBufferT frame (castPtr imageBuf) 148 | 149 | -- Fill up byte-string by data from buffer. 150 | MaybeT $ Just <$> 151 | unsafePackCStringFinalizer 152 | (castPtr imageBuf) 153 | (fromIntegral imageBufSize) 154 | -- Cleanup for buffer. 155 | imageBufCleanup 156 | 157 | -- Transformer version of copyImageData. 158 | copyImageDataT :: AVFrame -> MaybeT IO ByteString 159 | copyImageDataT = MaybeT . copyImageData 160 | 161 | -- Convert floating point second to millisecond. 162 | sec2msec :: (RealFrac a, Integral b) => a -> b 163 | sec2msec = floor . (*1000) 164 | 165 | -- Adjust window size by display size. 166 | -- It uses first display retrieved from call to SDL.getDisplays. 167 | -- I don't know yet how to get a display where window is opened. 168 | -- So this function won't be used right now. 169 | adjustWindowSize :: MonadIO m => SDL.Window -> m () 170 | adjustWindowSize w = do 171 | (SDL.V2 ww wh) <- SDL.get (SDL.windowSize w) 172 | (SDL.V2 dw dh) <- SDL.displayBoundsSize <$> firstDisplay 173 | let w' = min ww dw 174 | h' = min wh dh 175 | (SDL.windowSize w) SDL.$= (SDL.V2 w' h') 176 | where 177 | firstDisplay = SDL.getDisplays >>= return . head 178 | 179 | 180 | {- Main. -} 181 | 182 | -- Configuration for video player. 183 | data Config = 184 | Config 185 | { cfgWindowTitle :: Text 186 | , cfgRendererDriver :: CInt 187 | , cfgFmtFFmpeg :: AVPixelFormat 188 | , cfgFmtSDL :: SDL.PixelFormat 189 | } 190 | 191 | videoPlayer 192 | :: (MonadIO m, MonadError String m) 193 | => Config -> InputSource -> m () 194 | videoPlayer cfg src = do 195 | 196 | {- Setup. -} 197 | 198 | liftIO initFFmpeg 199 | SDL.initializeAll 200 | 201 | (renderTexture, getTexture, cleanup) <- textureReader src 202 | 203 | -- First frame begins. 204 | timeRef <- liftIO . newIORef =<< SDL.time 205 | 206 | liftIO $ whileJust_ (nothingOnQuit getTexture) $ 207 | \ (next, time) -> do 208 | 209 | {- Rendering. -} 210 | 211 | -- Rendering start time. 212 | rStartTime <- liftIO $ readIORef timeRef 213 | 214 | renderTexture next 215 | 216 | -- Finish time of rendering. 217 | rFinishTime <- SDL.time :: IO Double 218 | 219 | {- Synchronizing. -} 220 | 221 | -- Total rendering time. 222 | let rTotalTime = sec2msec $ rFinishTime - rStartTime 223 | -- Frame time in MS. 224 | frameTime = sec2msec time 225 | 226 | -- If rendering time is less then frame time. 227 | when ( time > 0 && rTotalTime < frameTime) $ do 228 | -- Sleep their difference. 229 | SDL.delay $ frameTime - rTotalTime 230 | 231 | -- Next frame begins. 232 | liftIO . writeIORef timeRef =<< SDL.time 233 | 234 | {- Cleanup. -} 235 | 236 | liftIO cleanup 237 | SDL.quit 238 | 239 | where 240 | 241 | -- Create window using title from config. 242 | createWindow w h = do 243 | window <- SDL.createWindow (cfgWindowTitle cfg) SDL.defaultWindow 244 | (SDL.$=) (SDL.windowSize window) (SDL.V2 w h) 245 | return window 246 | 247 | -- Create renderer using driver from config. 248 | createRenderer window = 249 | SDL.createRenderer window (cfgRendererDriver cfg) SDL.defaultRenderer 250 | 251 | -- Create texture using pixel format from config. 252 | createTexture renderer w h = 253 | SDL.createTexture 254 | renderer 255 | (cfgFmtSDL cfg) 256 | SDL.TextureAccessStreaming 257 | (SDL.V2 w h) 258 | 259 | -- Return texture reader, renderer and cleanup. 260 | textureReader :: (MonadIO m', MonadError String m', MonadIO m) 261 | => InputSource 262 | -> m' ( SDL.Texture -> m () 263 | , IO (Maybe (SDL.Texture, Double)) 264 | , IO ()) 265 | textureReader inp = do 266 | 267 | -- Open video. 268 | inputContext <- prepareInput inp 269 | (vsIdx, ctx, _, vs, _) <- prepareVideoCodec inputContext 270 | 271 | -- Get frame size. 272 | textureWidth <- liftIO $ getWidth ctx 273 | textureHeight <- liftIO $ getHeight ctx 274 | 275 | -- Compute window size. If the pixels aren't square, stretch the window, 276 | -- SDL will automatically scale the texture to fit. 277 | par <- liftIO $ guessAspectRatio ctx 278 | 279 | let pixelAspectRatio :: Double 280 | pixelAspectRatio = fromIntegral (numerator par) / fromIntegral (denomenator par) 281 | 282 | windowWidth, windowHeight :: CInt 283 | windowWidth = round (pixelAspectRatio * fromIntegral textureWidth) 284 | windowHeight = textureHeight 285 | 286 | -- Create window, renderer and texture. 287 | window <- createWindow windowWidth windowHeight 288 | renderer <- createRenderer window 289 | texture <- createTexture renderer textureWidth textureHeight 290 | 291 | -- Create frame reader. 292 | let dstFmt = cfgFmtFFmpeg cfg 293 | (reader, cleanup) <- prepareReader inputContext vsIdx dstFmt ctx 294 | 295 | -- Transform reader to read frame time. 296 | timeBase <- liftIO $ getTimeBase vs 297 | tsDiffReader <- readTSDiff (readTS timeBase reader) 298 | 299 | -- Texture reader. 300 | let reader' = runMaybeT $ do 301 | (f, t) <- MaybeT tsDiffReader 302 | updateTextureByFrameT texture f 303 | >>= return . flip (,) t 304 | 305 | -- Texture renderer. 306 | render t = do 307 | SDL.copy renderer t Nothing Nothing 308 | SDL.present renderer 309 | 310 | -- New cleanup. 311 | cleanup' = cleanup 312 | >> SDL.destroyTexture texture 313 | >> SDL.destroyRenderer renderer 314 | >> SDL.destroyWindow window 315 | 316 | return (render, reader', cleanup') 317 | 318 | 319 | {- Main. -} 320 | 321 | -- Default configuration. 322 | defaultConfig :: Config 323 | defaultConfig = 324 | Config 325 | { cfgWindowTitle = "VPLay" 326 | , cfgRendererDriver = (-1) -- find driver automatically. 327 | , cfgFmtFFmpeg = avPixFmtRgb24 328 | , cfgFmtSDL = SDL.RGB24 329 | } 330 | 331 | -- Runs videoPlayer in Either monad. 332 | runVideoPlayer :: Config -> FilePath -> IO (Either String ()) 333 | runVideoPlayer cfg = runExceptT . videoPlayer cfg . File 334 | 335 | -- Video player with default configuration. 336 | -- Command line argument: path to video file. 337 | main :: IO () 338 | main = getArgs >>= runVideoPlayer defaultConfig . head >> return () 339 | -------------------------------------------------------------------------------- /demo/logoTiny.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/acowley/ffmpeg-light/b0c464b96be0b983a1e6e62cb5d8cfb922159473/demo/logoTiny.gif -------------------------------------------------------------------------------- /ffmpeg-light.cabal: -------------------------------------------------------------------------------- 1 | name: ffmpeg-light 2 | version: 0.14.1 3 | synopsis: Minimal bindings to the FFmpeg library. 4 | 5 | description: Stream frames from an encoded video, or stream frames to 6 | a video output file. To read the first frame from 7 | an @h264@-encoded file into a JuicyPixels 8 | @Maybe DynamicImage@, 9 | . 10 | > import Codec.FFmpeg 11 | > import Codec.Picture 12 | > import Control.Applicative 13 | > 14 | > go :: IO (Maybe DynamicImage) 15 | > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" 16 | > (fmap ImageRGB8 <$> getFrame) <* cleanup 17 | . 18 | Tested with FFmpeg 3.1 - 3.4.2 19 | 20 | license: BSD3 21 | license-file: LICENSE 22 | author: Anthony Cowley 23 | maintainer: acowley@gmail.com 24 | copyright: Copyright (C) 2018 Anthony Cowley 25 | homepage: http://github.com/acowley/ffmpeg-light 26 | bug-reports: http://github.com/acowley/ffmpeg-light/issues 27 | category: Codec 28 | build-type: Simple 29 | extra-source-files: src/hscMacros.h, src/nameCompat.h, CHANGELOG.md 30 | cabal-version: >=1.10 31 | tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.1 || == 9.6.11 32 | 33 | source-repository head 34 | type: git 35 | location: http://github.com/acowley/ffmpeg-light.git 36 | 37 | flag BuildDemo 38 | description: Build demo executable 39 | default: False 40 | manual: True 41 | 42 | flag BuildRasterDemo 43 | description: Build Rasterific demo executable 44 | default: False 45 | manual: True 46 | 47 | flag BuildVPlayDemo 48 | description: Build video player demo executable 49 | default: False 50 | manual: True 51 | 52 | flag BuildTranscodeDemo 53 | description: Build transcode demo executable 54 | default: False 55 | manual: True 56 | 57 | flag BuildAudioExtractDemo 58 | description: Build audio-extract demo executable 59 | default: False 60 | manual: True 61 | 62 | flag BuildAudioSinDemo 63 | description: Build audio-sin demo executable 64 | default: False 65 | manual: True 66 | 67 | library 68 | exposed-modules: Codec.FFmpeg, 69 | Codec.FFmpeg.AudioStream, 70 | Codec.FFmpeg.Common, 71 | Codec.FFmpeg.Decode, 72 | Codec.FFmpeg.Encode, 73 | Codec.FFmpeg.Enums, 74 | Codec.FFmpeg.Juicy, 75 | Codec.FFmpeg.Probe, 76 | Codec.FFmpeg.Resampler, 77 | Codec.FFmpeg.Scaler, 78 | Codec.FFmpeg.Types, 79 | Codec.FFmpeg.Internal.Debug, 80 | Codec.FFmpeg.Internal.Linear 81 | build-tools: hsc2hs 82 | build-depends: base >=4.6 && < 5, 83 | either, 84 | exceptions, 85 | vector >= 0.10.9 && < 0.14, 86 | stm >= 2.0.0.0 && < 3.0.0.0.0, 87 | transformers >= 0.4.1 && < 0.7, 88 | mtl >= 2.2.1 && < 2.4, 89 | JuicyPixels >= 3.1 && < 3.4, 90 | bytestring 91 | 92 | pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice, 93 | libswresample 94 | hs-source-dirs: src 95 | include-dirs: src 96 | default-language: Haskell2010 97 | ghc-options: -Wall 98 | 99 | executable demo 100 | if !flag(BuildDemo) 101 | buildable: False 102 | build-depends: base < 5, vector, mtl, transformers, JuicyPixels 103 | if flag(BuildDemo) 104 | build-depends: ffmpeg-light, time 105 | hs-source-dirs: demo 106 | main-is: Main.hs 107 | default-language: Haskell2010 108 | ghc-options: -Wall 109 | 110 | executable raster 111 | if !flag(BuildRasterDemo) 112 | buildable: False 113 | build-depends: base < 5, vector, mtl, transformers, JuicyPixels >= 3.2 114 | if flag(BuildRasterDemo) 115 | build-depends: ffmpeg-light, Rasterific >= 0.3 116 | hs-source-dirs: demo 117 | main-is: Raster.hs 118 | default-language: Haskell2010 119 | ghc-options: -Wall -O2 120 | 121 | executable vplay 122 | if !flag(BuildVPlayDemo) 123 | buildable: False 124 | build-depends: base < 5, mtl, transformers, text, monad-loops, bytestring 125 | if flag(BuildVPlayDemo) 126 | build-depends: ffmpeg-light, sdl2 127 | hs-source-dirs: demo 128 | main-is: VPlay.hs 129 | default-language: Haskell2010 130 | ghc-options: -Wall -O2 131 | 132 | executable transcode 133 | if !flag(BuildTranscodeDemo) 134 | buildable: False 135 | build-depends: base < 5, JuicyPixels 136 | if flag(BuildTranscodeDemo) 137 | build-depends: ffmpeg-light 138 | hs-source-dirs: demo 139 | main-is: Transcode.hs 140 | default-language: Haskell2010 141 | ghc-options: -Wall 142 | 143 | executable audio-extract 144 | if !flag(BuildAudioExtractDemo) 145 | buildable: False 146 | build-depends: base < 5 147 | if flag(BuildAudioExtractDemo) 148 | build-depends: ffmpeg-light, mtl, vector 149 | hs-source-dirs: demo 150 | main-is: AudioExtract.hs 151 | default-language: Haskell2010 152 | ghc-options: -Wall 153 | 154 | executable audio-sin 155 | if !flag(BuildAudioSinDemo) 156 | buildable: False 157 | build-depends: base < 5 158 | if flag(BuildAudioSinDemo) 159 | build-depends: ffmpeg-light, mtl, vector, JuicyPixels 160 | hs-source-dirs: demo 161 | main-is: AudioSin.hs 162 | default-language: Haskell2010 163 | ghc-options: -Wall -------------------------------------------------------------------------------- /ffmpeg-ubuntu-compile.sh: -------------------------------------------------------------------------------- 1 | # FFmpeg compilation instructions from: 2 | # http://trac.ffmpeg.org/wiki/CompilationGuide/Ubuntu 3 | 4 | # Prepare to compile FFmpeg 5 | mkdir -p ~/ffmpeg_sources 6 | mkdir -p ~/ffmpeg_build 7 | mkdir -p ~/bin 8 | 9 | # libx264 10 | cd ~/ffmpeg_sources 11 | wget http://download.videolan.org/pub/x264/snapshots/last_x264.tar.bz2 12 | tar xjvf last_x264.tar.bz2 13 | cd x264-snapshot* 14 | PATH="$PATH:$HOME/bin" ./configure --prefix="$HOME/ffmpeg_build" --bindir="$HOME/bin" --enable-static --disable-opencl 15 | PATH="$PATH:$HOME/bin" make 16 | make install 17 | make distclean 18 | 19 | # libfdk-aac 20 | cd ~/ffmpeg_sources 21 | wget -O fdk-aac.zip https://github.com/mstorsjo/fdk-aac/zipball/master 22 | unzip fdk-aac.zip 23 | cd mstorsjo-fdk-aac* 24 | autoreconf -fiv 25 | ./configure --prefix="$HOME/ffmpeg_build" --disable-shared 26 | make 27 | make install 28 | make distclean 29 | 30 | # Compile FFmpeg 31 | cd ~/ffmpeg_sources 32 | wget http://ffmpeg.org/releases/ffmpeg-snapshot.tar.bz2 33 | tar xjvf ffmpeg-snapshot.tar.bz2 34 | cd ffmpeg 35 | PATH="$PATH:$HOME/bin" PKG_CONFIG_PATH="$HOME/ffmpeg_build/lib/pkgconfig" ./configure \ 36 | --prefix="$HOME/ffmpeg_build" \ 37 | --extra-cflags="-I$HOME/ffmpeg_build/include" \ 38 | --extra-ldflags="-L$HOME/ffmpeg_build/lib" \ 39 | --bindir="$HOME/bin" \ 40 | --enable-gpl \ 41 | --enable-libass \ 42 | --enable-libfdk-aac \ 43 | --enable-libmp3lame \ 44 | --enable-libx264 \ 45 | --enable-nonfree 46 | PATH="$PATH:$HOME/bin" make 47 | make install 48 | make distclean 49 | hash -r 50 | 51 | # ffmpeg-light 52 | cd 53 | cabal get ffmpeg-light 54 | cd ffmpeg-light* 55 | cabal install --dependencies-only 56 | PKG_CONFIG_PATH="$HOME/ffmpeg_build/lib/pkgconfig" cabal configure --disable-shared -fBuildDemo 57 | cabal build demo 58 | 59 | echo 'Now you should be able to "cabal run demo"' 60 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1644229661, 6 | "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nix-filter": { 19 | "locked": { 20 | "lastModified": 1646733795, 21 | "narHash": "sha256-W9elpjb6b4lqDsw6GxmLEVKaD1/nJQuBy/ikT76cL5c=", 22 | "owner": "numtide", 23 | "repo": "nix-filter", 24 | "rev": "e4e8649a3b6f0d3c181955945a84e6918d3f832a", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "numtide", 29 | "repo": "nix-filter", 30 | "type": "github" 31 | } 32 | }, 33 | "nixpkgs": { 34 | "locked": { 35 | "lastModified": 1646506091, 36 | "narHash": "sha256-sWNAJE2m+HOh1jtXlHcnhxsj6/sXrHgbqVNcVRlveK4=", 37 | "owner": "nixos", 38 | "repo": "nixpkgs", 39 | "rev": "3e644bd62489b516292c816f70bf0052c693b3c7", 40 | "type": "github" 41 | }, 42 | "original": { 43 | "owner": "nixos", 44 | "ref": "nixpkgs-unstable", 45 | "repo": "nixpkgs", 46 | "type": "github" 47 | } 48 | }, 49 | "root": { 50 | "inputs": { 51 | "flake-utils": "flake-utils", 52 | "nix-filter": "nix-filter", 53 | "nixpkgs": "nixpkgs" 54 | } 55 | } 56 | }, 57 | "root": "root", 58 | "version": 7 59 | } 60 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Haskell wrapper for the ffmpeg library"; 3 | 4 | inputs = { 5 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 6 | flake-utils.url = "github:numtide/flake-utils"; 7 | nix-filter.url = "github:numtide/nix-filter"; 8 | }; 9 | 10 | outputs = { self, nixpkgs, flake-utils, nix-filter }: 11 | flake-utils.lib.eachDefaultSystem (system: 12 | let pkgs = import nixpkgs { 13 | inherit system; 14 | }; 15 | # compiler = "8107"; 16 | compiler = "921"; 17 | hspkgs = 18 | let doJailbreak = pkgs.haskell.lib.doJailbreak; 19 | dontCheck = pkgs.haskell.lib.dontCheck; 20 | in pkgs.haskell.packages."ghc${compiler}".override { 21 | overrides = final: prev: 22 | if compiler == "921" 23 | then { 24 | linear = prev.callHackage "linear" "1.21.8" {}; 25 | sdl2 = dontCheck (prev.callHackage "sdl2" "2.5.3.1" {}); 26 | } 27 | else { }; 28 | }; 29 | ffmpeg-light = hspkgs.callPackage (import ./default.nix) { nix-filter = nix-filter.lib; }; 30 | ghc = hspkgs.ghc.withHoogle (ps: ffmpeg-light.passthru.getBuildInputs.haskellBuildInputs); 31 | in { 32 | devShell = pkgs.mkShell { 33 | buildInputs = [ 34 | pkgs.SDL2 pkgs.ffmpeg pkgs.pkgconfig 35 | ghc hspkgs.cabal-install 36 | # hspkgs.haskell-language-server 37 | ]; 38 | }; 39 | packages.ffmpeg-light = ffmpeg-light; 40 | defaultPackage = self.packages.${system}.ffmpeg-light; 41 | } 42 | ); 43 | } 44 | -------------------------------------------------------------------------------- /hackagedocs.sh: -------------------------------------------------------------------------------- 1 | # Based on https://gist.github.com/Fuuzetsu/8276421 2 | # Usage: sh hackagedocs.sh ffmpeg-light 0.7.1 UserName Password 3 | 4 | cabal configure && cabal build && cabal haddock --hyperlink-source \ 5 | --html-location='http://hackage.haskell.org/package/$pkg/docs' \ 6 | --contents-location='http://hackage.haskell.org/package/$pkg' 7 | S=$? 8 | if [ "${S}" -eq "0" ]; then 9 | cd "dist/doc/html" 10 | DDIR="${1}-${2}-docs" 11 | cp -r "${1}" "${DDIR}" && tar -c -v -z --format ustar -f "${DDIR}.tar.gz" "${DDIR}" 12 | CS=$? 13 | if [ "${CS}" -eq "0" ]; then 14 | echo "Uploading to Hackage…" 15 | curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@${DDIR}.tar.gz" "http://${3}:${4}@hackage.haskell.org/package/${1}-${2}/docs" 16 | exit $? 17 | else 18 | echo "Error when packaging the documentation" 19 | exit $CS 20 | fi 21 | else 22 | echo "Error when trying to build the package." 23 | exit $S 24 | fi 25 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, FlexibleContexts #-} 2 | -- | Interface to initialize FFmpeg, decode video files, encode video 3 | -- files, and convert decoded image frames to JuicyPixels images. 4 | module Codec.FFmpeg (-- * Initialization 5 | initFFmpeg, setLogLevel, 6 | -- * Decoding 7 | imageReader, imageReaderTime, 8 | imageReaderT, imageReaderTimeT, 9 | -- * Encoding 10 | EncodingParams(..), StreamParams(..), 11 | VideoParams(..), AudioParams(..), 12 | defaultParams, imageWriter, 13 | -- * Types and Enums 14 | module Codec.FFmpeg.Types, 15 | module Codec.FFmpeg.Enums 16 | )where 17 | import Codec.FFmpeg.Encode 18 | import Codec.FFmpeg.Enums 19 | import Codec.FFmpeg.Juicy 20 | import Codec.FFmpeg.Resampler 21 | import Codec.FFmpeg.Types 22 | import Foreign.C.Types (CInt(..)) 23 | 24 | foreign import ccall "av_register_all" av_register_all :: IO () 25 | foreign import ccall "avdevice_register_all" avdevice_register_all :: IO () 26 | 27 | -- foreign import ccall "avcodec_register_all" avcodec_register_all :: IO ( 28 | 29 | foreign import ccall "av_log_set_level" av_log_set_level :: CInt -> IO () 30 | 31 | -- | Log output is sent to stderr. 32 | setLogLevel :: LogLevel -> IO () 33 | setLogLevel (LogLevel l) = av_log_set_level l 34 | 35 | -- | Initialize FFmpeg by registering all known codecs. This /must/ be 36 | -- called before using other FFmpeg functions. The debug level is 37 | -- initially set to @quiet@. If you would like the standard ffmpeg 38 | -- debug level, call @setLogLevel avLogInfo@ after @initFFmpeg@. 39 | initFFmpeg :: IO () 40 | initFFmpeg = av_register_all >> avdevice_register_all >> setLogLevel avLogQuiet 41 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/AudioStream.hs: -------------------------------------------------------------------------------- 1 | module Codec.FFmpeg.AudioStream where 2 | 3 | import Codec.FFmpeg.Enums 4 | import Data.Bits 5 | import qualified Data.Vector.Storable as V 6 | import Foreign.C.Types 7 | 8 | data AudioStream = AudioStream 9 | { asBitRate :: CInt 10 | , asSampleFormat :: AVSampleFormat 11 | , asSampleRate :: CInt 12 | , asChannelLayout :: CULong 13 | , asChannelCount :: CInt 14 | , asCodec :: AVCodecID 15 | } 16 | 17 | -- These are all defined as #defines so I don't think we can FFI them 18 | avChFrontLeft :: CULong 19 | avChFrontLeft = 0x00000001 20 | 21 | avChFrontRight :: CULong 22 | avChFrontRight = 0x00000002 23 | 24 | avChFrontCenter :: CULong 25 | avChFrontCenter = 0x00000004 26 | 27 | avChLowFrequency :: CULong 28 | avChLowFrequency = 0x00000008 29 | 30 | avChBackLeft :: CULong 31 | avChBackLeft = 0x00000010 32 | 33 | avChBackRight :: CULong 34 | avChBackRight = 0x00000020 35 | 36 | avChFrontLeftOfCenter :: CULong 37 | avChFrontLeftOfCenter = 0x00000040 38 | 39 | avChFrontRightOfCenter :: CULong 40 | avChFrontRightOfCenter = 0x00000080 41 | 42 | avChBackCenter :: CULong 43 | avChBackCenter = 0x00000100 44 | 45 | avChSideLeft :: CULong 46 | avChSideLeft = 0x00000200 47 | 48 | avChSideRight :: CULong 49 | avChSideRight = 0x00000400 50 | 51 | avChTopCenter :: CULong 52 | avChTopCenter = 0x00000800 53 | 54 | avChTopFrontLeft :: CULong 55 | avChTopFrontLeft = 0x00001000 56 | 57 | avChTopFrontCenter :: CULong 58 | avChTopFrontCenter = 0x00002000 59 | 60 | avChTopFrontRight :: CULong 61 | avChTopFrontRight = 0x00004000 62 | 63 | avChTopBackLeft :: CULong 64 | avChTopBackLeft = 0x00008000 65 | 66 | avChTopBackCenter :: CULong 67 | avChTopBackCenter = 0x00010000 68 | 69 | avChTopBackRight :: CULong 70 | avChTopBackRight = 0x00020000 71 | 72 | avChStereoLeft :: CULong 73 | avChStereoLeft = 0x20000000 74 | 75 | avChStereoRight :: CULong 76 | avChStereoRight = 0x40000000 77 | 78 | avChLayoutMono = avChFrontCenter 79 | avChLayoutStereo = avChFrontLeft .|. avChFrontRight 80 | avChLayout2point1 = avChLayoutStereo .|. avChLowFrequency 81 | avChLayout21 = avChLayoutStereo .|. avChBackCenter 82 | avChLayoutSurround = avChLayoutStereo .|. avChFrontCenter 83 | avChLayout3point1 = avChLayoutSurround .|. avChLowFrequency 84 | avChLayout4point0 = avChLayoutSurround .|. avChBackCenter 85 | avChLayout4point1 = avChLayout4point0 .|. avChLowFrequency 86 | avChLayout22 = avChLayoutStereo .|. avChSideLeft .|. avChSideRight 87 | avChLayoutQuad = avChLayoutStereo .|. avChBackLeft .|. avChBackRight 88 | avChLayout5point0 = avChLayoutSurround .|. avChSideLeft .|. avChSideRight 89 | avChLayout5point1 = avChLayout5point0 .|. avChLowFrequency 90 | avChLayout5point0Back = avChLayoutSurround .|. avChBackLeft .|. avChBackRight 91 | avChLayout5point1Back = avChLayout5point0Back .|. avChLowFrequency 92 | avChLayout6point0 = avChLayout5point0 .|. avChBackCenter 93 | avChLayout6point0Front = avChLayout22 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter 94 | avChLayoutHexagonal = avChLayout5point0Back .|. avChBackCenter 95 | avChLayout6point1 = avChLayout5point1 .|. avChBackCenter 96 | avChLayout6point1Back = avChLayout5point1Back .|. avChBackCenter 97 | avChLayout6point1Front = avChLayout6point0Front .|. avChLowFrequency 98 | avChLayout7point0 = avChLayout5point0 .|. avChBackLeft .|. avChBackRight 99 | avChLayout7point0Front = avChLayout5point0 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter 100 | avChLayout7point1 = avChLayout5point1 .|. avChBackLeft .|. avChBackRight 101 | -- avChLayout7point1Wide = avChLayout5point1 .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter 102 | -- avChLayout7point1WideBack = avChLayout5point1Back .|. avChFrontLeftOfCenter .|. avChFrontRightOfCenter 103 | avChLayoutOctagonal = avChLayout5point0 .|. avChBackLeft .|. avChBackCenter .|. avChBackRight 104 | -- avChLayoutHexadecagonal = avChLayoutOctagonal .|. avChWideLeft .|. avChWideRight .|. avChTopBackLeft .|. avChTopBackRight .|. avChTopBackCenter .|. avChTopFrontCenter .|. avChTopFrontLeft .|. avChTopFrontRight 105 | avChLayoutStereoDownmix = avChStereoLeft .|. avChStereoRight 106 | 107 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Common.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | module Codec.FFmpeg.Common where 4 | import Codec.FFmpeg.Enums 5 | import Codec.FFmpeg.Types 6 | import Control.Exception 7 | import Control.Monad (when) 8 | import Control.Monad.Error.Class 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Trans.Maybe 11 | import Foreign.C.String 12 | import Foreign.C.Types 13 | import Foreign.Marshal.Alloc (allocaBytes, free) 14 | import Foreign.Marshal.Array (advancePtr, mallocArray) 15 | import Foreign.Ptr 16 | import Foreign.Storable 17 | 18 | foreign import ccall "avcodec_open2" 19 | open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt 20 | 21 | foreign import ccall "av_frame_alloc" 22 | av_frame_alloc :: IO AVFrame 23 | 24 | foreign import ccall "av_frame_get_buffer" 25 | av_frame_get_buffer :: AVFrame -> CInt -> IO CInt 26 | 27 | foreign import ccall "av_frame_free" 28 | av_frame_free :: Ptr AVFrame -> IO () 29 | 30 | foreign import ccall "avcodec_close" 31 | codec_close :: AVCodecContext -> IO CInt 32 | 33 | foreign import ccall "av_init_packet" 34 | init_packet :: AVPacket -> IO () 35 | 36 | foreign import ccall "av_packet_alloc" 37 | av_packet_alloc :: IO AVPacket 38 | 39 | foreign import ccall "av_free_packet" 40 | free_packet :: AVPacket -> IO () 41 | 42 | foreign import ccall "av_malloc" 43 | av_malloc :: CSize -> IO (Ptr ()) 44 | 45 | foreign import ccall "av_free" 46 | av_free :: Ptr () -> IO () 47 | 48 | foreign import ccall "sws_getCachedContext" 49 | sws_getCachedContext :: SwsContext 50 | -> CInt -> CInt -> AVPixelFormat 51 | -> CInt -> CInt -> AVPixelFormat 52 | -> SwsAlgorithm -> Ptr () -> Ptr () -> Ptr CDouble 53 | -> IO SwsContext 54 | 55 | foreign import ccall "sws_scale" 56 | sws_scale :: SwsContext 57 | -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt 58 | -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt 59 | 60 | foreign import ccall "av_get_channel_layout_nb_channels" 61 | av_get_channel_layout_nb_channels :: CULong -> IO CInt 62 | 63 | foreign import ccall "swr_alloc" 64 | swr_alloc :: IO SwrContext 65 | 66 | foreign import ccall "swr_init" 67 | swr_init :: SwrContext -> IO CInt 68 | 69 | foreign import ccall "av_opt_set_int" 70 | av_opt_set_int :: Ptr () -> CString -> CLong -> CInt -> IO CInt 71 | 72 | foreign import ccall "av_opt_get_int" 73 | av_opt_get_int :: Ptr () -> CString -> CInt -> Ptr CULong -> IO CInt 74 | 75 | foreign import ccall "av_opt_set_sample_fmt" 76 | av_opt_set_sample_fmt :: Ptr () -> CString -> AVSampleFormat -> CInt -> IO CInt 77 | 78 | foreign import ccall "av_opt_get_sample_fmt" 79 | av_opt_get_sample_fmt :: Ptr () -> CString -> CInt -> Ptr AVSampleFormat -> IO CInt 80 | 81 | foreign import ccall "avcodec_send_frame" 82 | avcodec_send_frame :: AVCodecContext -> AVFrame -> IO CInt 83 | 84 | foreign import ccall "avcodec_send_packet" 85 | avcodec_send_packet :: AVCodecContext -> AVPacket -> IO CInt 86 | 87 | foreign import ccall "avcodec_receive_frame" 88 | avcodec_receive_frame :: AVCodecContext -> AVFrame -> IO CInt 89 | 90 | foreign import ccall "avcodec_receive_packet" 91 | avcodec_receive_packet :: AVCodecContext -> AVPacket -> IO CInt 92 | 93 | foreign import ccall "av_get_channel_name" 94 | av_get_channel_name :: CULong -> IO CString 95 | 96 | foreign import ccall "av_get_channel_description" 97 | av_get_channel_description :: CULong -> IO CString 98 | 99 | -- Return size of buffer for image. 100 | foreign import ccall "av_image_get_buffer_size" 101 | av_image_get_buffer_size 102 | -- Pixel format. 103 | :: AVPixelFormat 104 | -- Width. 105 | -> CInt 106 | -- Height. 107 | -> CInt 108 | -- Line size alignment. 109 | -> CInt 110 | -- Size of buffer. 111 | -> IO CInt 112 | 113 | -- Copy image to buffer. 114 | foreign import ccall "av_image_copy_to_buffer" 115 | av_image_copy_to_buffer 116 | -- Destination buffer. 117 | :: Ptr CUChar 118 | -- Destination buffer size. 119 | -> CInt 120 | -- Source image data. 121 | -> Ptr (Ptr CUChar) 122 | -- Source image line size. 123 | -> Ptr CInt 124 | -- Source image pixel format. 125 | -> AVPixelFormat 126 | -- Source image width. 127 | -> CInt 128 | -- Source image height. 129 | -> CInt 130 | -- Source image line size alignment. 131 | -> CInt 132 | -- Number of bytes written to destination. 133 | -> IO CInt 134 | 135 | 136 | -- * Utility functions 137 | 138 | -- | Catch an IOException from an IO action and re-throw it in a 139 | -- wrapping monad transformer. 140 | wrapIOError :: (MonadIO m, MonadError String m) => IO a -> m a 141 | wrapIOError io = liftIO (catchError (fmap Right io) (return . Left . show)) 142 | >>= either throwError return 143 | 144 | newtype FFmpegException = FFmpegException String deriving Show 145 | 146 | instance Exception FFmpegException 147 | 148 | runWithError :: String -> IO CInt -> IO CInt 149 | runWithError msg toRun = do 150 | r <- toRun 151 | when (r < 0) $ do 152 | let len = 100 -- I have no idea how long this string should be so this is a guess 153 | errCStr <- mallocArray len 154 | av_strerror r errCStr (fromIntegral len) 155 | errStr <- peekCString errCStr 156 | free errCStr 157 | avError $ msg ++ " : " ++ errStr 158 | return r 159 | 160 | avError :: String -> IO a 161 | avError msg = throwIO $ FFmpegException $ msg 162 | 163 | -- * Wrappers that may throw 'IOException's. 164 | 165 | -- | Allocate an 'AVFrame' and set its fields to default values. 166 | frame_alloc_check :: IO AVFrame 167 | frame_alloc_check = do r <- av_frame_alloc 168 | when (getPtr r == nullPtr) 169 | (error "Couldn't allocate frame") 170 | return r 171 | 172 | -- | Allocate new buffer(s) for audio or video data with the required 173 | -- alignment. Note, for video frames, pixel format, @width@, and 174 | -- @height@ must be set before calling this function. For audio 175 | -- frames, sample @format@, @nb_samples@, and @channel_layout@ must be 176 | -- set. 177 | frame_get_buffer_check :: AVFrame -> CInt -> IO () 178 | frame_get_buffer_check f x = do r <- av_frame_get_buffer f x 179 | when (r /= 0) 180 | (error "Failed to allocate buffers") 181 | 182 | -- | Bytes-per-pixel for an 'AVPixelFormat' 183 | avPixelStride :: AVPixelFormat -> Maybe Int 184 | avPixelStride fmt 185 | | fmt == avPixFmtGray8 = Just 1 186 | | fmt == avPixFmtRgb24 = Just 3 187 | | fmt == avPixFmtRgba = Just 4 188 | | fmt == avPixFmtRgb8 = Just 1 189 | | fmt == avPixFmtPal8 = Just 1 190 | | otherwise = Nothing 191 | 192 | -- | Return line size alignment. 193 | lineSizeAlign :: CInt -> CInt 194 | lineSizeAlign lineSize 195 | -- Alignment for 512 bit register. 196 | | lineSize `mod` 64 == 0 = 64 197 | -- Alignment for 256 bit register. 198 | | lineSize `mod` 32 == 0 = 32 199 | -- Alignment for 128 bit register. 200 | | lineSize `mod` 16 == 0 = 16 201 | -- Alignment for 64 bit register. 202 | | lineSize `mod` 8 == 0 = 8 203 | -- Alignment for 32 bit register. 204 | | lineSize `mod` 4 == 0 = 4 205 | -- Alignment for 16 bit register. 206 | | lineSize `mod` 2 == 0 = 2 207 | -- Alignment for 8 bit register. 208 | | otherwise = 1 209 | 210 | -- | Retun 'AVFrame's line size. 211 | frameLineSize :: AVFrame -> IO (Maybe CInt) 212 | frameLineSize frame = do 213 | w <- getWidth frame 214 | fmt <- getPixelFormat frame 215 | return $ 216 | (*w) . fromIntegral <$> avPixelStride fmt 217 | 218 | -- | Transformer version of 'frameLineSize'. 219 | frameLineSizeT :: AVFrame -> MaybeT IO CInt 220 | frameLineSizeT = MaybeT . frameLineSize 221 | 222 | -- Return 'AVFrame's alignment. 223 | frameAlign :: AVFrame -> IO (Maybe CInt) 224 | frameAlign = fmap (fmap lineSizeAlign) . frameLineSize 225 | 226 | -- Transformer version of 'frameAlign'. 227 | frameAlignT :: AVFrame -> MaybeT IO CInt 228 | frameAlignT = MaybeT . frameAlign 229 | 230 | 231 | -- * Wrappers for copying 'AVFrame's image to buffer. 232 | 233 | -- | Return size of buffer for 'AVFrame's image. 234 | frameBufferSize :: AVFrame -> IO (Maybe CInt) 235 | frameBufferSize frame = 236 | runMaybeT $ do 237 | a <- frameAlignT frame 238 | MaybeT $ do 239 | fmt <- getPixelFormat frame 240 | w <- getWidth frame 241 | h <- getHeight frame 242 | Just <$> av_image_get_buffer_size fmt w h a 243 | 244 | -- | Transformer version of 'frameBufferSize'. 245 | frameBufferSizeT :: AVFrame -> MaybeT IO CInt 246 | frameBufferSizeT = MaybeT . frameBufferSize 247 | 248 | -- | Copy 'AVFrame's image to buffer. 249 | -- It is assumed that size of buffer is equal to 250 | -- 251 | -- > bufSize <- fromJust <$> frameBufferSize frame. 252 | frameCopyToBuffer :: AVFrame -> Ptr CUChar -> IO (Maybe CInt) 253 | frameCopyToBuffer frame buffer = 254 | runMaybeT $ do 255 | 256 | a <- frameAlignT frame 257 | s <- frameBufferSizeT frame 258 | 259 | MaybeT $ do 260 | 261 | let imageData = hasData frame 262 | lineSize = hasLineSize frame 263 | 264 | fmt <- getPixelFormat frame 265 | w <- getWidth frame 266 | h <- getHeight frame 267 | 268 | Just <$> 269 | av_image_copy_to_buffer 270 | buffer 271 | s 272 | (castPtr imageData) 273 | lineSize 274 | fmt 275 | w 276 | h 277 | a 278 | 279 | -- | Transformer version of 'frameCopyToBuffer'. 280 | frameCopyToBufferT :: AVFrame -> Ptr CUChar -> MaybeT IO CInt 281 | frameCopyToBufferT frame = MaybeT . frameCopyToBuffer frame 282 | 283 | -- * FFmpeg Errors 284 | 285 | foreign import ccall "av_strerror" 286 | av_strerror :: CInt -> Ptr CChar -> CSize -> IO CInt 287 | 288 | stringError :: CInt -> IO String 289 | stringError err = 290 | allocaBytes len $ \block -> do 291 | let buf = castPtr block 292 | _ <- av_strerror err buf (fromIntegral len) 293 | peekCString buf 294 | where 295 | len = 1000 296 | 297 | -- | Walk a C array placing the values into a Haskell list. 298 | -- Stop incrementing the pointer when the function returns True 299 | walkPtrs :: Storable a 300 | => Ptr a -- ^ Ptr to the beginning of an array 301 | -> (Ptr a -> IO Bool) -- ^ Function to specify when we should terminate 302 | -> IO [a] 303 | walkPtrs ptr isDone = do 304 | d <- isDone ptr 305 | if d 306 | then return [] 307 | else do 308 | v <- peek ptr 309 | rest <- walkPtrs (advancePtr ptr 1) isDone 310 | return $ v : rest 311 | 312 | listSupportedSampleFormats :: AVCodec -> IO [AVSampleFormat] 313 | listSupportedSampleFormats codec = do 314 | fmts <- getSampleFormats codec 315 | walkPtrs fmts (\ptr -> 316 | if ptr == nullPtr 317 | then return True 318 | else do 319 | v <- peek ptr 320 | return $ getSampleFormatInt v == -1 321 | ) 322 | 323 | listSupportedChannelLayouts :: AVCodec -> IO [CULong] 324 | listSupportedChannelLayouts codec = do 325 | chanPtr <- getChannelLayouts codec 326 | walkPtrs chanPtr (\ptr -> 327 | if ptr == nullPtr 328 | then return True 329 | else do 330 | v <- peek ptr 331 | return $ v == 0 332 | ) 333 | 334 | listSupportedSampleRates :: AVCodec -> IO [CInt] 335 | listSupportedSampleRates codec = do 336 | srPtr <- getSupportedSampleRates codec 337 | walkPtrs srPtr (\ptr -> 338 | if ptr == nullPtr 339 | then return True 340 | else do 341 | v <- peek ptr 342 | return $ v == 0 343 | ) 344 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Decode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | -- | Video decoding API. Includes FFI declarations for the underlying 5 | -- FFmpeg functions, wrappers for these functions that wrap error 6 | -- condition checking, and high level Haskellized interfaces. 7 | module Codec.FFmpeg.Decode where 8 | 9 | import Codec.FFmpeg.AudioStream 10 | import Codec.FFmpeg.Common 11 | import Codec.FFmpeg.Enums 12 | import Codec.FFmpeg.Scaler 13 | import Codec.FFmpeg.Types 14 | import Control.Arrow (first) 15 | import Control.Monad (void, when) 16 | import Control.Monad.Except 17 | import Control.Monad.IO.Class (MonadIO(liftIO)) 18 | import Control.Monad.Trans.Maybe 19 | import Foreign.C.String 20 | import Foreign.C.Types 21 | import Foreign.Marshal.Alloc (alloca, free, mallocBytes) 22 | import Foreign.Marshal.Array (advancePtr) 23 | import Foreign.Marshal.Utils (with) 24 | import Foreign.Ptr 25 | import Foreign.Storable 26 | 27 | -- * FFI Declarations 28 | 29 | foreign import ccall "avformat_open_input" 30 | avformat_open_input :: Ptr AVFormatContext -> CString -> Ptr AVInputFormat 31 | -> Ptr AVDictionary -> IO CInt 32 | 33 | foreign import ccall "avformat_find_stream_info" 34 | avformat_find_stream_info :: AVFormatContext -> Ptr () -> IO CInt 35 | 36 | foreign import ccall "av_find_best_stream" 37 | av_find_best_stream :: AVFormatContext -> AVMediaType -> CInt -> CInt 38 | -> Ptr AVCodec -> CInt -> IO CInt 39 | 40 | foreign import ccall "avcodec_find_decoder" 41 | avcodec_find_decoder :: AVCodecID -> IO AVCodec 42 | 43 | foreign import ccall "avcodec_find_decoder_by_name" 44 | avcodec_find_decoder_by_name :: CString -> IO AVCodec 45 | 46 | foreign import ccall "avpicture_get_size" 47 | avpicture_get_size :: AVPixelFormat -> CInt -> CInt -> IO CInt 48 | 49 | foreign import ccall "av_malloc" 50 | av_malloc :: CSize -> IO (Ptr ()) 51 | 52 | foreign import ccall "av_read_frame" 53 | av_read_frame :: AVFormatContext -> AVPacket -> IO CInt 54 | 55 | foreign import ccall "avcodec_decode_audio4" 56 | decode_audio :: AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket 57 | -> IO CInt 58 | 59 | foreign import ccall "avcodec_decode_video2" 60 | decode_video :: AVCodecContext -> AVFrame -> Ptr CInt -> AVPacket 61 | -> IO CInt 62 | foreign import ccall "avformat_close_input" 63 | close_input :: Ptr AVFormatContext -> IO () 64 | 65 | foreign import ccall "av_dict_set" 66 | av_dict_set :: Ptr AVDictionary -> CString -> CString -> CInt -> IO CInt 67 | 68 | foreign import ccall "av_find_input_format" 69 | av_find_input_format :: CString -> IO (Ptr AVInputFormat) 70 | 71 | foreign import ccall "av_format_set_video_codec" 72 | av_format_set_video_codec :: AVFormatContext -> AVCodec -> IO () 73 | 74 | dictSet :: Ptr AVDictionary -> String -> String -> IO () 75 | dictSet d k v = do 76 | r <- withCString k $ \k' -> withCString v $ \v' -> 77 | av_dict_set d k' v' 0 78 | when (r < 0) $ 79 | stringError r >>= \err -> 80 | error $ "av_dict_set failed("++ err ++"): "++k++" => "++v 81 | 82 | -- * FFmpeg Decoding Interface 83 | 84 | -- | Open the first video input device enumerated by FFMPEG. 85 | openCamera :: (MonadIO m, MonadError String m) => String -> CameraConfig -> m AVFormatContext 86 | openCamera cam cfg = 87 | wrapIOError . alloca $ \ctx -> 88 | withCString cam $ \cstr -> 89 | do avPtr <- mallocAVFormatContext 90 | setupCamera avPtr cam 91 | poke ctx avPtr 92 | fmt <- case format cfg of 93 | Just "mjpeg" -> withCString "v4l2" av_find_input_format 94 | Just f -> withCString f av_find_input_format 95 | Nothing -> pure nullPtr 96 | r <- alloca $ \dict -> do 97 | setConfig dict cfg 98 | avformat_open_input ctx cstr fmt dict 99 | when (r /= 0) $ 100 | stringError r >>= \err -> 101 | fail ("ffmpeg failed opening file: " ++ err) 102 | peek ctx 103 | where 104 | run :: (a -> IO b) -> Maybe a -> IO () 105 | run _ Nothing = return () 106 | run f (Just x) = void (f x) 107 | 108 | setConfig :: Ptr AVDictionary -> CameraConfig -> IO () 109 | setConfig dict (CameraConfig {..}) = 110 | do run (dictSet dict "framerate" . show) framerate 111 | run (\(w,h) -> dictSet dict "video_size" (show w ++ "x" ++ show h)) resolution 112 | 113 | setupCamera :: AVFormatContext -> String -> IO () 114 | setupCamera avfc c = 115 | do setCamera avfc 116 | setFilename avfc c 117 | when (format cfg == Just "mjpeg") $ do 118 | mjpeg <- avcodec_find_decoder avCodecIdMjpeg 119 | setVideoCodecID avfc avCodecIdMjpeg 120 | av_format_set_video_codec avfc mjpeg 121 | 122 | openInput :: (MonadIO m, MonadError String m) => InputSource -> m AVFormatContext 123 | openInput ipt = 124 | case ipt of 125 | File fileName -> openFile fileName 126 | Camera cam cf -> openCamera cam cf 127 | 128 | -- | Open an input media file. 129 | openFile :: (MonadIO m, MonadError String m) => String -> m AVFormatContext 130 | openFile filename = 131 | wrapIOError . alloca $ \ctx -> 132 | withCString filename $ \cstr -> 133 | do poke (castPtr ctx) nullPtr 134 | r <- avformat_open_input ctx cstr nullPtr nullPtr 135 | when (r /= 0) (stringError r >>= \s -> 136 | fail $ "ffmpeg failed opening file: " ++ s) 137 | peek ctx 138 | 139 | -- | @AVFrame@ is a superset of @AVPicture@, so we can upcast an 140 | -- 'AVFrame' to an 'AVPicture'. 141 | frameAsPicture :: AVFrame -> AVPicture 142 | frameAsPicture = AVPicture . getPtr 143 | 144 | -- | Find a codec given by name. 145 | findDecoder :: (MonadIO m, MonadError String m) => String -> m AVCodec 146 | findDecoder name = 147 | do r <- liftIO $ withCString name avcodec_find_decoder_by_name 148 | when (getPtr r == nullPtr) 149 | (throwError $ "Unsupported codec: " ++ show name) 150 | return r 151 | 152 | -- | Read packets of a media file to get stream information. This is 153 | -- useful for file formats with no headers such as MPEG. 154 | checkStreams :: (MonadIO m, MonadError String m) => AVFormatContext -> m () 155 | checkStreams ctx = 156 | do r <- liftIO $ avformat_find_stream_info ctx nullPtr 157 | when (r < 0) (throwError "Couldn't find stream information") 158 | 159 | -- | Searches for a video stream in an 'AVFormatContext'. If one is 160 | -- found, returns the index of the stream in the container, and its 161 | -- associated 'AVCodecContext' and 'AVCodec'. 162 | findVideoStream :: (MonadIO m, MonadError String m) 163 | => AVFormatContext 164 | -> m (CInt, AVCodecContext, AVCodec, AVStream) 165 | findVideoStream fmt = do 166 | wrapIOError . alloca $ \codec -> do 167 | poke codec (AVCodec nullPtr) 168 | i <- av_find_best_stream fmt avmediaTypeVideo (-1) (-1) codec 0 169 | when (i < 0) (fail "Couldn't find a video stream") 170 | cod <- peek codec 171 | streams <- getStreams fmt 172 | vidStream <- peek (advancePtr streams (fromIntegral i)) 173 | ctx <- getCodecContext vidStream 174 | return (i, ctx, cod, vidStream) 175 | 176 | findAudioStream :: (MonadIO m, MonadError String m) 177 | => AVFormatContext 178 | -> m (CInt, AVCodecContext, AVCodec, AVStream) 179 | findAudioStream fmt = do 180 | wrapIOError . alloca $ \codec -> do 181 | poke codec (AVCodec nullPtr) 182 | i <- av_find_best_stream fmt avmediaTypeAudio (-1) (-1) codec 0 183 | when (i < 0) (fail "Couldn't find audio stream") 184 | cod <- peek codec 185 | streams <- getStreams fmt 186 | audioStream <- peek (advancePtr streams (fromIntegral i)) 187 | ctx <- getCodecContext audioStream 188 | return (i, ctx, cod, audioStream) 189 | 190 | -- | Find a registered decoder with a codec ID matching that found in 191 | -- the given 'AVCodecContext'. 192 | getDecoder :: (MonadIO m, MonadError String m) 193 | => AVCodecContext -> m AVCodec 194 | getDecoder ctx = do p <- liftIO $ getCodecID ctx >>= avcodec_find_decoder 195 | when (getPtr p == nullPtr) (throwError "Unsupported codec") 196 | return p 197 | 198 | -- | Initialize the given 'AVCodecContext' to use the given 199 | -- 'AVCodec'. **NOTE**: This function is not thread safe! 200 | openCodec :: (MonadIO m, MonadError String m) 201 | => AVCodecContext -> AVCodec -> m AVDictionary 202 | openCodec ctx cod = 203 | wrapIOError . alloca $ \dict -> do 204 | poke dict (AVDictionary nullPtr) 205 | r <- open_codec ctx cod dict 206 | when (r < 0) (fail "Couldn't open decoder") 207 | peek dict 208 | 209 | -- | Return the next frame of a stream. 210 | read_frame_check :: AVFormatContext -> AVPacket -> IO () 211 | read_frame_check ctx pkt = do r <- av_read_frame ctx pkt 212 | when (r < 0) (fail "Frame read failed") 213 | 214 | -- | Read frames of the given 'AVPixelFormat' from a video stream. 215 | frameReader :: (MonadIO m, MonadError String m) 216 | => AVPixelFormat -> InputSource -> m (IO (Maybe AVFrame), IO ()) 217 | frameReader dstFmt ipt = 218 | do inputContext <- openInput ipt 219 | checkStreams inputContext 220 | (vidStreamIndex, ctx, cod, _vidStream) <- findVideoStream inputContext 221 | _ <- openCodec ctx cod 222 | prepareReader inputContext vidStreamIndex dstFmt ctx 223 | 224 | -- | Read RGB frames with the result in the 'MaybeT' transformer. 225 | -- 226 | -- > frameReaderT = fmap (first MaybeT) . frameReader 227 | frameReaderT :: (Functor m, MonadIO m, MonadError String m) 228 | => InputSource -> m (MaybeT IO AVFrame, IO ()) 229 | frameReaderT = fmap (first MaybeT) . frameReader avPixFmtRgb24 230 | 231 | -- | Read time stamped frames of the given 'AVPixelFormat' from a 232 | -- video stream. Time is given in seconds from the start of the 233 | -- stream. 234 | frameReaderTime :: (MonadIO m, MonadError String m) 235 | => AVPixelFormat -> InputSource 236 | -> m (IO (Maybe (AVFrame, Double)), IO ()) 237 | frameReaderTime dstFmt src = 238 | do inputContext <- openInput src 239 | checkStreams inputContext 240 | (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inputContext 241 | _ <- openCodec ctx cod 242 | (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx 243 | AVRational num den <- liftIO $ getTimeBase vidStream 244 | let (numl, dend) = (fromIntegral num, fromIntegral den) 245 | frameTime' frame = 246 | do n <- getPts frame 247 | return $ fromIntegral (n * numl) / dend 248 | readTS = do frame <- reader 249 | case frame of 250 | Nothing -> return Nothing 251 | Just f -> do t <- frameTime' f 252 | return $ Just (f, t) 253 | return (readTS, cleanup) 254 | 255 | frameAudioReader :: (MonadIO m, MonadError String m) 256 | => InputSource -> m (AudioStream, IO (Maybe AVFrame), IO ()) 257 | frameAudioReader fileName = do 258 | inputContext <- openInput fileName 259 | checkStreams inputContext 260 | (audioStreamIndex, ctx, cod, audioStream) <- findAudioStream inputContext 261 | openCodec ctx cod 262 | as <- liftIO $ do 263 | bitrate <- getBitRate ctx 264 | samplerate <- getSampleRate ctx 265 | channelLayout <- getChannelLayout ctx 266 | sampleFormat <- getSampleFormat ctx 267 | channels <- getChannels ctx 268 | codecId <- getCodecID cod 269 | return $ AudioStream 270 | { asBitRate = bitrate 271 | , asSampleRate = samplerate 272 | , asSampleFormat = sampleFormat 273 | , asChannelLayout = channelLayout 274 | , asChannelCount = channels 275 | , asCodec = codecId 276 | } 277 | (readFrame, finalize) <- prepareAudioReader inputContext audioStreamIndex ctx 278 | return (as, readFrame, finalize) 279 | 280 | -- | Read time stamped RGB frames with the result in the 'MaybeT' 281 | -- transformer. 282 | -- 283 | -- > frameReaderT = fmap (first MaybeT) . frameReader 284 | frameReaderTimeT :: (Functor m, MonadIO m, MonadError String m) 285 | => InputSource -> m (MaybeT IO (AVFrame, Double), IO ()) 286 | frameReaderTimeT = fmap (first MaybeT) . frameReaderTime avPixFmtRgb24 287 | 288 | prepareAudioReader :: (MonadIO m, MonadError String m) 289 | => AVFormatContext -> CInt -> AVCodecContext 290 | -> m (IO (Maybe AVFrame), IO ()) 291 | prepareAudioReader fmtCtx audStream codCtx = 292 | wrapIOError $ do 293 | frame <- frame_alloc_check 294 | pkt <- av_packet_alloc 295 | let cleanup = do with frame av_frame_free 296 | _ <- codec_close codCtx 297 | with fmtCtx close_input 298 | free (getPtr pkt) 299 | getFrame = do 300 | ret <- avcodec_receive_frame codCtx frame 301 | if ret < 0 302 | then do 303 | r <- av_read_frame fmtCtx pkt 304 | if r < 0 305 | then return Nothing 306 | else do 307 | whichStream <- getStreamIndex pkt 308 | if whichStream == audStream 309 | then do 310 | runWithError "Error sending packet" (avcodec_send_packet codCtx pkt) 311 | getFrame 312 | else free_packet pkt >> getFrame 313 | else return $ Just frame 314 | return (getFrame `catchError` const (return Nothing), cleanup) 315 | 316 | -- | Construct an action that gets the next available frame, and an 317 | -- action to release all resources associated with this video stream. 318 | prepareReader :: (MonadIO m, MonadError String m) 319 | => AVFormatContext -> CInt -> AVPixelFormat -> AVCodecContext 320 | -> m (IO (Maybe AVFrame), IO ()) 321 | prepareReader fmtCtx vidStream dstFmt codCtx = 322 | wrapIOError $ 323 | do fRaw <- frame_alloc_check 324 | fRgb <- frame_alloc_check 325 | 326 | w <- getWidth codCtx 327 | h <- getHeight codCtx 328 | fmt <- getPixelFormat codCtx 329 | 330 | setWidth fRgb w 331 | setHeight fRgb h 332 | setPixelFormat fRgb dstFmt 333 | 334 | frame_get_buffer_check fRgb 32 335 | 336 | sws <- swsInit (ImageInfo w h fmt) (ImageInfo w h dstFmt) swsBilinear 337 | 338 | pkt <- AVPacket <$> mallocBytes packetSize 339 | let cleanup = do with fRgb av_frame_free 340 | with fRaw av_frame_free 341 | _ <- codec_close codCtx 342 | with fmtCtx close_input 343 | free (getPtr pkt) 344 | getFrame = do 345 | read_frame_check fmtCtx pkt 346 | whichStream <- getStreamIndex pkt 347 | if whichStream == vidStream 348 | then do 349 | fin <- alloca $ \finished -> do 350 | _ <- decode_video codCtx fRaw finished pkt 351 | peek finished 352 | if fin > 0 353 | then do 354 | -- Some streaming codecs require a final flush with 355 | -- an empty packet 356 | -- fin' <- alloca $ \fin2 -> do 357 | -- free_packet pkt 358 | -- (#poke AVPacket, data) pkt nullPtr 359 | -- (#poke AVPacket, size) pkt (0::CInt) 360 | -- decode_video codCtx fRaw fin2 pkt 361 | -- peek fin2 362 | 363 | _ <- swsScale sws fRaw fRgb 364 | 365 | -- Copy the raw frame's timestamp to the RGB frame 366 | getPktPts fRaw >>= setPts fRgb 367 | 368 | free_packet pkt 369 | return $ Just fRgb 370 | else free_packet pkt >> getFrame 371 | else free_packet pkt >> getFrame 372 | return (getFrame `catchError` const (return Nothing), cleanup) 373 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Encode.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | -- | Video encoding API. Includes FFI declarations for the underlying 3 | -- FFmpeg functions, wrappers for these functions that wrap error 4 | -- condition checking, and high level Haskellized interfaces. 5 | -- 6 | -- Note: If you need to import this module, consider qualifying the 7 | -- import. 8 | module Codec.FFmpeg.Encode where 9 | import Codec.FFmpeg.Common 10 | import Codec.FFmpeg.Enums 11 | import Codec.FFmpeg.Internal.Linear 12 | import Codec.FFmpeg.Resampler 13 | import Codec.FFmpeg.Scaler 14 | import Codec.FFmpeg.Types 15 | import Codec.Picture 16 | import Control.Monad (when, void) 17 | import Data.Bits 18 | import Data.IORef 19 | import Data.Maybe (fromMaybe) 20 | import Data.Ord (comparing) 21 | import Data.Traversable (for) 22 | import Data.Vector.Storable (Vector) 23 | import qualified Data.Vector.Storable as V 24 | import qualified Data.Vector.Storable.Mutable as VM 25 | import Foreign.C.String 26 | import Foreign.C.Types 27 | import Foreign.ForeignPtr (touchForeignPtr) 28 | import Foreign.Marshal.Alloc 29 | import Foreign.Marshal.Array (advancePtr) 30 | import Foreign.Marshal.Utils 31 | 32 | import Codec.FFmpeg.Internal.Debug 33 | 34 | import Foreign.Ptr 35 | import Foreign.Storable 36 | 37 | #include 38 | 39 | -- Based on the FFmpeg muxing example 40 | -- http://www.ffmpeg.org/doxygen/2.1/doc_2examples_2muxing_8c-example.html 41 | 42 | -- * FFI Declarations 43 | 44 | foreign import ccall "avcodec_find_encoder" 45 | avcodec_find_encoder :: AVCodecID -> IO AVCodec 46 | 47 | foreign import ccall "avcodec_find_encoder_by_name" 48 | avcodec_find_encoder_by_name :: CString -> IO AVCodec 49 | 50 | foreign import ccall "av_opt_set" 51 | av_opt_set :: Ptr () -> CString -> CString -> CInt -> IO CInt 52 | 53 | foreign import ccall "avcodec_encode_video2" 54 | avcodec_encode_video2 :: AVCodecContext -> AVPacket -> AVFrame -> Ptr CInt 55 | -> IO CInt 56 | 57 | foreign import ccall "av_image_alloc" 58 | av_image_alloc :: Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt 59 | -> AVPixelFormat -> CInt -> IO CInt 60 | 61 | foreign import ccall "av_freep" 62 | av_freep :: Ptr (Ptr a) -> IO () 63 | 64 | foreign import ccall "av_guess_format" 65 | av_guess_format :: CString -> CString -> CString -> IO AVOutputFormat 66 | 67 | foreign import ccall "avformat_alloc_output_context2" 68 | avformat_alloc_output_context2 :: Ptr AVFormatContext -> AVOutputFormat 69 | -> CString -> CString -> IO CInt 70 | 71 | foreign import ccall "avformat_new_stream" 72 | avformat_new_stream :: AVFormatContext -> AVCodec -> IO AVStream 73 | 74 | foreign import ccall "av_write_frame" 75 | av_write_frame :: AVFormatContext -> AVPacket -> IO CInt 76 | 77 | foreign import ccall "av_interleaved_write_frame" 78 | av_interleaved_write_frame :: AVFormatContext -> AVPacket -> IO CInt 79 | 80 | foreign import ccall "avformat_write_header" 81 | avformat_write_header :: AVFormatContext -> Ptr AVDictionary -> IO CInt 82 | 83 | foreign import ccall "av_write_trailer" 84 | av_write_trailer :: AVFormatContext -> IO CInt 85 | 86 | foreign import ccall "avio_open" 87 | avio_open :: Ptr AVIOContext -> CString -> AVIOFlag -> IO CInt 88 | 89 | foreign import ccall "avio_close" 90 | avio_close :: AVIOContext -> IO CInt 91 | 92 | foreign import ccall "avformat_free_context" 93 | avformat_free_context :: AVFormatContext -> IO () 94 | 95 | foreign import ccall "av_image_fill_arrays" 96 | av_image_fill_arrays :: Ptr (Ptr CUChar) -> Ptr CInt -> Ptr CUChar 97 | -> AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt 98 | 99 | foreign import ccall "av_image_fill_linesizes" 100 | av_image_fill_linesizes :: Ptr CInt -> AVPixelFormat -> CInt -> IO CInt 101 | 102 | foreign import ccall "av_frame_make_writable" 103 | av_frame_make_writable :: AVFrame -> IO CInt 104 | 105 | -- * FFmpeg Encoding Interface 106 | 107 | -- | Minimal parameters describing the desired video output. 108 | data EncodingParams = EncodingParams 109 | { epWidth :: CInt 110 | , epHeight :: CInt 111 | , epFps :: Int 112 | , epCodec :: Maybe AVCodecID 113 | -- ^ If 'Nothing', then the codec is inferred from 114 | -- the output file name. If 'Just', then this codec 115 | -- is manually chosen. 116 | , epPixelFormat :: Maybe AVPixelFormat 117 | -- ^ If 'Nothing', automatically chose a pixel format 118 | -- based on the output codec. If 'Just', force the 119 | -- selected pixel format. 120 | , epPreset :: String 121 | -- ^ Encoder-specific hints. For h264, the default 122 | -- preset is @\"medium\"@ (other options are 123 | -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec, 124 | -- setting this to @\"dither\"@ will enable dithering 125 | -- during the palettization process. This will 126 | -- improve image quality, but result in a larger 127 | -- file. 128 | , epFormatName :: Maybe String 129 | -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer 130 | -- from the output file name. If 'Just', the string value 131 | -- should be the one available in @ffmpeg -formats@. 132 | } 133 | 134 | -- | Minimal parameters describing the desired audio/video output. 135 | data AVEncodingParams = AVEncodingParams 136 | { avepWidth :: CInt 137 | , avepHeight :: CInt 138 | , avepFps :: Int 139 | , avepCodec :: Maybe AVCodecID 140 | -- ^ If 'Nothing', then the codec is inferred from 141 | -- the output file name. If 'Just', then this codec 142 | -- is manually chosen. 143 | , avepPixelFormat :: Maybe AVPixelFormat 144 | -- ^ If 'Nothing', automatically chose a pixel format 145 | -- based on the output codec. If 'Just', force the 146 | -- selected pixel format. 147 | , avepChannelLayout :: CULong 148 | -- ^ Channel layout for the audio stream 149 | , avepSampleRate :: CInt 150 | -- ^ Sample rate for the audio stream 151 | , avepSampleFormat :: AVSampleFormat 152 | -- ^ Sample format for the audio stream 153 | , avepPreset :: String 154 | -- ^ Encoder-specific hints. For h264, the default 155 | -- preset is @\"medium\"@ (other options are 156 | -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec, 157 | -- setting this to @\"dither\"@ will enable dithering 158 | -- during the palettization process. This will 159 | -- improve image quality, but result in a larger 160 | -- file. 161 | , avepFormatName :: Maybe String 162 | -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer 163 | -- from the output file name. If 'Just', the string value 164 | -- should be the one available in @ffmpeg -formats@. 165 | } 166 | 167 | -- | Minimal parameters describing the desired audio/video output. 168 | data AEncodingParams = AEncodingParams 169 | { aepChannelLayout :: CULong 170 | -- ^ Channel layout for the audio stream 171 | , aepSampleRate :: CInt 172 | -- ^ Sample rate for the audio stream 173 | , aepSampleFormat :: AVSampleFormat 174 | -- ^ Sample format for the audio stream 175 | , aepPreset :: String 176 | -- ^ Encoder-specific hints. For h264, the default 177 | -- preset is @\"medium\"@ (other options are 178 | -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec, 179 | -- setting this to @\"dither\"@ will enable dithering 180 | -- during the palettization process. This will 181 | -- improve image quality, but result in a larger 182 | -- file. 183 | , aepFormatName :: Maybe String 184 | -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer 185 | -- from the output file name. If 'Just', the string value 186 | -- should be the one available in @ffmpeg -formats@. 187 | } 188 | 189 | data VideoParams = VideoParams 190 | { vpWidth :: CInt 191 | , vpHeight :: CInt 192 | , vpFps :: Int 193 | , vpCodec :: Maybe AVCodecID 194 | , vpPixelFormat :: Maybe AVPixelFormat 195 | , vpPreset :: String 196 | } 197 | 198 | class HasVideoParams a where 199 | extractVideoParams :: a -> VideoParams 200 | 201 | instance HasVideoParams EncodingParams where 202 | extractVideoParams ep = VideoParams 203 | { vpWidth = epWidth ep 204 | , vpHeight = epHeight ep 205 | , vpFps = epFps ep 206 | , vpCodec = epCodec ep 207 | , vpPixelFormat = epPixelFormat ep 208 | , vpPreset = epPreset ep 209 | } 210 | 211 | instance HasVideoParams AVEncodingParams where 212 | extractVideoParams ep = VideoParams 213 | { vpWidth = avepWidth ep 214 | , vpHeight = avepHeight ep 215 | , vpFps = avepFps ep 216 | , vpCodec = avepCodec ep 217 | , vpPixelFormat = avepPixelFormat ep 218 | , vpPreset = avepPreset ep 219 | } 220 | 221 | class HasAudioParams a where 222 | extractAudioParams :: a -> AudioParams 223 | 224 | instance HasAudioParams AEncodingParams where 225 | extractAudioParams ep = AudioParams 226 | { apChannelLayout = aepChannelLayout ep 227 | , apSampleRate = aepSampleRate ep 228 | , apSampleFormat = aepSampleFormat ep 229 | } 230 | 231 | instance HasAudioParams AVEncodingParams where 232 | extractAudioParams ep = AudioParams 233 | { apChannelLayout = avepChannelLayout ep 234 | , apSampleRate = avepSampleRate ep 235 | , apSampleFormat = avepSampleFormat ep 236 | } 237 | 238 | -- | Use default parameters for a video of the given width and 239 | -- height, forcing the choice of the h264 encoder. 240 | defaultH264 :: CInt -> CInt -> EncodingParams 241 | defaultH264 w h = 242 | EncodingParams 243 | { epWidth = w 244 | , epHeight = h 245 | , epFps = 30 246 | , epCodec = (Just avCodecIdH264) 247 | , epPixelFormat = Nothing 248 | , epPreset = "medium" 249 | , epFormatName = Nothing 250 | } 251 | 252 | -- | Use default parameters for a video of the given width and 253 | -- height. The output format is determined by the output file name. 254 | defaultParams :: CInt -> CInt -> EncodingParams 255 | defaultParams w h = 256 | EncodingParams 257 | { epWidth = w 258 | , epHeight = h 259 | , epFps = 30 260 | , epCodec = Nothing 261 | , epPixelFormat = Nothing 262 | , epPreset = "" 263 | , epFormatName = Nothing 264 | } 265 | 266 | -- | Determine if the bitwise intersection of two values is non-zero. 267 | checkFlag :: Bits a => a -> a -> Bool 268 | checkFlag flg = \x -> (flg .&. x) /= allZeroBits 269 | where allZeroBits = clearBit (bit 0) 0 270 | 271 | -- | Find and initialize the requested encoder, and add a video stream 272 | -- to the output container. 273 | initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext) 274 | initStream ep oc = initVideoStream (extractVideoParams ep) oc 275 | 276 | initVideoStream :: VideoParams -> AVFormatContext -> IO (AVStream, AVCodecContext) 277 | initVideoStream vp _ 278 | | (vpWidth vp `rem` 2, vpHeight vp `rem` 2) /= (0,0) = 279 | error "Video dimensions must be multiples of two" 280 | initVideoStream vp oc = do 281 | -- Use the codec suggested by the output format, or override with 282 | -- the user's choice. 283 | codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (vpCodec vp) 284 | cod <- avcodec_find_encoder codec 285 | when (getPtr cod == nullPtr) 286 | (error "Couldn't find encoder") 287 | 288 | st <- avformat_new_stream oc cod 289 | getNumStreams oc >>= setId st . subtract 1 290 | let framePeriod = AVRational 1 (fromIntegral $ vpFps vp) 291 | frameRate = AVRational (fromIntegral $ vpFps vp) 1 292 | setTimeBase st framePeriod 293 | ctx <- getCodecContext st 294 | setWidth ctx (vpWidth vp) 295 | setHeight ctx (vpHeight vp) 296 | setTimeBase ctx framePeriod 297 | setFrameRate ctx frameRate 298 | setPixelFormat ctx $ case vpPixelFormat vp of 299 | Just fmt -> fmt 300 | Nothing 301 | | codec == avCodecIdRawvideo -> avPixFmtRgb24 302 | | codec == avCodecIdGif -> avPixFmtPal8 303 | | otherwise -> avPixFmtYuv420p 304 | 305 | -- Some formats want stream headers to be separate 306 | needsHeader <- checkFlag avfmtGlobalheader <$> 307 | (getOutputFormat oc >>= getFormatFlags) 308 | when needsHeader $ 309 | #if LIBAVFORMAT_VERSION_MAJOR < 57 310 | getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader) 311 | #else 312 | getCodecFlags ctx >>= setCodecFlags ctx . (.|. avCodecFlagGlobalHeader) 313 | #endif 314 | 315 | -- _ <- withCString "vprofile" $ \kStr -> 316 | -- withCString (preset ep) $ \vStr -> 317 | -- av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx)) 318 | -- kStr vStr 0 319 | when (not . null $ vpPreset vp) . void $ 320 | withCString "preset" $ \kStr -> 321 | withCString (vpPreset vp) $ \vStr -> 322 | getPrivData ctx >>= \pd -> av_opt_set pd kStr vStr 0 323 | 324 | rOpen <- open_codec ctx cod nullPtr 325 | when (rOpen < 0) (error "Couldn't open codec") 326 | 327 | return (st, ctx) 328 | 329 | initAudioStream :: AudioParams 330 | -> AVFormatContext 331 | -> IO (AVStream, AVCodec, AVCodecContext) 332 | initAudioStream params oc = do 333 | codecId <- getAudioCodecID =<< getOutputFormat oc 334 | print codecId 335 | cod <- avcodec_find_encoder codecId 336 | when (getPtr cod == nullPtr) (avError "Could not find audio codec") 337 | 338 | st <- avformat_new_stream oc cod 339 | getNumStreams oc >>= setId st . subtract 1 340 | setTimeBase st (AVRational 1 (apSampleRate params)) 341 | 342 | ctx <- avcodec_alloc_context3 cod 343 | 344 | supportedSampleRates <- listSupportedSampleFormats cod 345 | let found = not (null supportedSampleRates) 346 | when (not found) $ avError "Could not find supported sample rate" 347 | -- TODO: check that these are valid 348 | setSampleFormat ctx (apSampleFormat params) 349 | setSampleRate ctx (apSampleRate params) 350 | 351 | setChannelLayout ctx (apChannelLayout params) 352 | 353 | runWithError "Could not open audio codec" (open_codec ctx cod nullPtr) 354 | 355 | codecParams <- getCodecParams st 356 | runWithError "Could not copy params" (avcodec_parameters_from_context codecParams ctx) 357 | 358 | return (st, cod, ctx) 359 | 360 | 361 | -- | Initialize a temporary YUV frame of the same resolution as the 362 | -- output video stream. We well convert RGB frames using this frame as 363 | -- a destination before encoding the video frame. 364 | initTempFrame :: VideoParams -> AVPixelFormat -> IO AVFrame 365 | initTempFrame vp fmt = do 366 | frame <- frame_alloc_check 367 | setPixelFormat frame fmt 368 | setWidth frame (vpWidth vp) 369 | setHeight frame (vpHeight vp) 370 | setPts frame 0 371 | 372 | -- For palettized images, we will provide our own buffer. 373 | if fmt == avPixFmtRgb8 || fmt == avPixFmtPal8 374 | then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (vpWidth vp) 375 | when (r < 0) (error "Error filling temporary frame line sizes") 376 | else frame_get_buffer_check frame 32 377 | return frame 378 | 379 | -- | Allocate an output context inferring the codec from the given 380 | -- file name. 381 | allocOutputContext :: Maybe String -> FilePath -> IO AVFormatContext 382 | allocOutputContext outputFormat fname = do 383 | let withFormat = case outputFormat of 384 | Just f -> withCString f 385 | Nothing -> (\f -> f nullPtr) 386 | oc <- alloca $ \ocTmp -> do 387 | r <- withCString fname $ \fname' -> 388 | withFormat $ \format -> 389 | avformat_alloc_output_context2 390 | ocTmp (AVOutputFormat nullPtr) 391 | format fname' 392 | when (r < 0) 393 | (error "Couldn't allocate output format context") 394 | peek ocTmp 395 | when (getPtr oc == nullPtr) 396 | (error "Couldn't allocate iutput AVFormatContext") 397 | return oc 398 | 399 | -- | Open the given file for writing. 400 | avio_open_check :: AVFormatContext -> String -> IO () 401 | avio_open_check oc fname = 402 | do r <- withCString fname $ \cstr -> 403 | avio_open (hasIOContext oc) cstr avioFlagWrite 404 | when (r < 0) (error "Error opening IO for writing") 405 | 406 | -- | Close an open IO context. 407 | avio_close_check :: AVFormatContext -> IO () 408 | avio_close_check oc = do r <- getIOContext oc >>= avio_close 409 | when (r /= 0) (error "Error closing IO") 410 | 411 | -- | Returns 'True' if the 'AVPacket' was updated with new output 412 | -- data; 'False' otherwise. 413 | encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool 414 | encode_video_check ctx pkt frame = 415 | alloca $ \gotOutput -> do 416 | r <- avcodec_encode_video2 ctx pkt frame' gotOutput 417 | when (r < 0) (error "Error encoding frame") 418 | (> 0) <$> peek gotOutput 419 | where frame' = fromMaybe (AVFrame nullPtr) frame 420 | 421 | -- | Allocate the stream private data and write the stream header to 422 | -- an output media file. 423 | write_header_check :: AVFormatContext -> IO () 424 | write_header_check oc = 425 | void $ runWithError "write header" (avformat_write_header oc nullPtr) 426 | 427 | -- | Write a packet to an output media file. 428 | write_frame_check :: AVFormatContext -> AVPacket -> IO () 429 | write_frame_check oc pkt = do r <- av_write_frame oc pkt 430 | when (r < 0) (error "Error writing frame") 431 | 432 | -- | Write the stream trailer to an output media file and free the 433 | -- private data. May only be called after a successful call to 434 | -- 'write_header_check'. 435 | write_trailer_check :: AVFormatContext -> IO () 436 | write_trailer_check oc = do r <- av_write_trailer oc 437 | when (r /= 0) (error "Error writing trailer") 438 | 439 | -- | Quantize RGB24 pixels to the systematic RGB8 color palette. The 440 | -- image data has space for a palette appended to be compliant with 441 | -- 'av_image_fill_arrays''s expectations. This is slow. 442 | palettizeRGB8 :: VideoParams -> V.Vector CUChar -> V.Vector CUChar 443 | palettizeRGB8 vp = \pix -> V.create $ 444 | do let pix' = V.unsafeCast pix :: V.Vector (V3 CUChar) 445 | m <- VM.new (numPix + 1024) 446 | V.mapM_ (\i -> let p = searchPal $ fromIntegral <$> (pix' V.! i) 447 | in VM.unsafeWrite m i p) 448 | (V.enumFromN 0 numPix) 449 | VM.set (VM.unsafeSlice numPix 1024 m) 0 450 | return m 451 | where numPix = fromIntegral $ vpWidth vp * vpHeight vp 452 | pal :: V.Vector (V3 CInt) 453 | pal = V.generate 256 $ \i' -> 454 | let i = fromIntegral i' 455 | in V3 ((i `shiftR` 5) * 36) 456 | (((i `shiftR` 2) .&. 7) * 36) 457 | ((i .&. 3) * 85) 458 | searchPal = fromIntegral . flip V.minIndexBy pal . comparing . qd 459 | 460 | -- | High quality dithered, median cut palette using 'palettize'. The 461 | -- result is packed such that the BGRA palette is laid out 462 | -- contiguously following the palettized image data. 463 | palettizeJuicy :: VideoParams -> V.Vector CUChar -> V.Vector CUChar 464 | palettizeJuicy vp pix = 465 | let (pix', pal) = palettize (PaletteOptions MedianMeanCut doDither 256) 466 | (mkImage $ V.unsafeCast pix) 467 | pal' = V.map (\(V3 r g b) -> V4 b g r (255::CUChar)) 468 | (V.unsafeCast $ imageData pal) 469 | in V.unsafeCast (imageData pix') V.++ V.unsafeCast pal' 470 | where mkImage = Image (fromIntegral $ vpWidth vp) (fromIntegral $ vpHeight vp) 471 | doDither = vpPreset vp == "dither" 472 | 473 | {-# DEPRECATED frameWriter "Please use videoWriter instead." #-} 474 | frameWriter :: EncodingParams -> FilePath 475 | -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()) 476 | frameWriter ep fname = do 477 | let sp = JustVideo (extractVideoParams ep) 478 | writerContext <- avWriter (epFormatName ep) sp fname 479 | return (avwVideoWriter writerContext) 480 | 481 | -- | Open a target file for writing a video stream. The function 482 | -- returned may be used to write image frames (specified by a pixel 483 | -- format, resolution, and pixel data). If this function is applied to 484 | -- 'Nothing', then the output stream is closed. Note that 'Nothing' 485 | -- /must/ be provided to properly terminate video encoding. 486 | -- 487 | -- Support for source images that are of a different size to the 488 | -- output resolution is limited to non-palettized destination formats 489 | -- (i.e. those that are handled by @libswscaler@). Practically, this 490 | -- means that animated gif output only works if the source images are 491 | -- of the target resolution. 492 | videoWriter :: EncodingParams -> FilePath 493 | -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()) 494 | videoWriter ep fname = do 495 | let sp = JustVideo (extractVideoParams ep) 496 | writerContext <- avWriter (epFormatName ep) sp fname 497 | return (avwVideoWriter writerContext) 498 | 499 | data StreamParams = 500 | JustVideo VideoParams 501 | | JustAudio AudioParams 502 | | AudioVideo AudioParams VideoParams 503 | 504 | withVideoParams :: StreamParams -> a -> (VideoParams -> a) -> a 505 | withVideoParams sp def f = 506 | case sp of 507 | JustVideo vp -> f vp 508 | AudioVideo _ vp -> f vp 509 | _ -> def 510 | 511 | withAudioParams :: StreamParams -> a -> (AudioParams -> a) -> a 512 | withAudioParams sp def f = 513 | case sp of 514 | JustAudio ap -> f ap 515 | AudioVideo ap _ -> f ap 516 | _ -> def 517 | 518 | -- | Open a target for writing an audio stream. 519 | audioWriter :: AEncodingParams 520 | -> FilePath 521 | -> IO (Maybe AVCodecContext, Maybe AVFrame -> IO ()) 522 | audioWriter ep fname = do 523 | let sp = JustAudio (extractAudioParams ep) 524 | writerContext <- avWriter (aepFormatName ep) sp fname 525 | return (avwAudioCodecContext writerContext, avwAudioWriter writerContext) 526 | 527 | data AVWriterContext = AVWriterContext 528 | { avwVideoCodecContext :: Maybe AVCodecContext 529 | , avwAudioCodecContext :: Maybe AVCodecContext 530 | , avwVideoWriter :: Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO () 531 | , avwAudioWriter :: Maybe AVFrame -> IO () 532 | } 533 | 534 | -- | Open a target for writing a video and audio file. 535 | audioVideoWriter :: AVEncodingParams -> FilePath -> IO AVWriterContext 536 | audioVideoWriter ep fname = do 537 | let sp = AudioVideo (extractAudioParams ep) (extractVideoParams ep) 538 | avWriter (avepFormatName ep) sp fname 539 | 540 | -- | For internal use only. Use 'videoWriter', 'audioWriter', or 'audioVideoWriter' instead. 541 | avWriter :: Maybe String 542 | -> StreamParams 543 | -> FilePath 544 | -> IO AVWriterContext 545 | avWriter outputFormat sp fname = do 546 | oc <- allocOutputContext outputFormat fname 547 | outputFormat <- getOutputFormat oc 548 | audioCodecId <- getAudioCodecID outputFormat 549 | videoCodecId <- getVideoCodecID outputFormat 550 | 551 | -- Initializing the streams needs to be done before opening the file 552 | -- and checking the header because it can modify fields that are used 553 | -- for time scaling so we have this rather ugly code. 554 | mVideoStream <- withVideoParams sp (return Nothing) $ \vp -> 555 | (Just <$> initVideoStream vp oc) 556 | mAudioStream <- withAudioParams sp (return Nothing) $ \ap -> 557 | (Just <$> initAudioStream ap oc) 558 | avio_open_check oc fname 559 | numStreams <- getNumStreams oc 560 | write_header_check oc 561 | 562 | alreadyClosedRef <- newIORef False 563 | let writeClose = do 564 | alreadyClosed <- readIORef alreadyClosedRef 565 | when (not alreadyClosed) $ do 566 | write_trailer_check oc 567 | modifyIORef alreadyClosedRef (const True) 568 | 569 | initializeVideo :: AVStream 570 | -> AVCodecContext 571 | -> VideoParams 572 | -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()) 573 | initializeVideo st ctx vp = do 574 | dstFmt <- getPixelFormat ctx 575 | dstFrame <- initTempFrame vp dstFmt 576 | let dstInfo = ImageInfo (vpWidth vp) (vpHeight vp) dstFmt 577 | 578 | -- Initialize the scaler that we use to convert RGB -> dstFmt 579 | -- Note that libswscaler does not support Pal8 as an output format. 580 | sws <- if dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 581 | then swsInit (ImageInfo (vpWidth vp) (vpHeight vp) avPixFmtRgb24) 582 | dstInfo swsBilinear 583 | >>= fmap Just . newIORef 584 | else return Nothing 585 | 586 | pkt <- AVPacket <$> av_malloc (fromIntegral packetSize) 587 | setPts pkt 0 588 | 589 | stIndex <- getStreamIndex st 590 | 591 | -- Frame number ioref. We use this to determine whether we should 592 | -- increment the frame PTS; we only want to do this for frames after 593 | -- the first one since we want the first frame PTS to be zero. 594 | frameNum <- newIORef (0::Int) 595 | 596 | let framePeriod = AVRational 1 (fromIntegral $ vpFps vp) 597 | fps <- getFps ctx 598 | 599 | -- The stream time_base can be changed by the call to 600 | -- 'write_header_check', so we read it back here to establish a way 601 | -- of scaling the nominal, desired frame rate (given by 602 | -- 'framePeriod') to the stream's time_base. 603 | tb <- getTimeBase st 604 | #if LIBAVFORMAT_VERSION_MAJOR < 57 605 | isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) 606 | #endif 607 | 608 | let checkPalCompat 609 | | dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 = const True 610 | | otherwise = \(srcFmt, V2 srcW srcH, _) -> 611 | srcFmt == avPixFmtRgb24 && 612 | srcW == vpWidth vp && 613 | srcH == vpHeight vp 614 | 615 | palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy vp 616 | | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 vp 617 | | otherwise = Nothing 618 | frameTime = av_rescale_q 1 framePeriod tb 619 | resetPacket = do init_packet pkt 620 | setPktData pkt nullPtr 621 | setSize pkt 0 622 | writePacket = do setStreamIndex pkt stIndex 623 | write_frame_check oc pkt 624 | 625 | copyDstData (_,_,pixels) = 626 | void . V.unsafeWith pixels $ \ptr -> 627 | av_image_fill_arrays (castPtr $ hasData dstFrame) 628 | (hasLineSize dstFrame) 629 | (castPtr ptr) 630 | dstFmt 631 | (vpWidth vp) 632 | (vpHeight vp) 633 | 1 634 | 635 | scaleToDst sws' img = void $ swsScale sws' img dstFrame 636 | fillDst = maybe copyDstData scaleToDst 637 | 638 | -- | Gets the PTS to be used for the current frame by reading the 639 | -- PTS from dstFrame. If the current frame is the first frame 640 | -- (zero), the existing timestamp is left unmodified. Otherwise it 641 | -- is incremented by frameTime. 642 | -- 643 | -- This also increments the current frame number stored in the 644 | -- frameNum IORef so the caller needn't worry about it. 645 | getCurrentFrameTimestamp = do 646 | curFrame <- readIORef frameNum 647 | ts <- case curFrame == 0 of 648 | True -> getPts dstFrame 649 | False -> (+ frameTime) <$> getPts dstFrame 650 | modifyIORef frameNum (+1) 651 | return ts 652 | #if LIBAVFORMAT_VERSION_MAJOR < 57 653 | addRaw Nothing = return () 654 | addRaw (Just (_, _, pixels)) = 655 | do resetPacket 656 | getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey) 657 | --setSize pkt (fromIntegral $ V.length pixels) 658 | setSize pkt (fromIntegral pictureSize) 659 | timeStamp <- getCurrentFrameTimestamp 660 | setPts dstFrame timeStamp 661 | setPts pkt timeStamp 662 | -- getPts dstFrame >>= setDts pkt 663 | V.unsafeWith pixels $ \ptr -> do 664 | setData pkt (castPtr ptr) 665 | writePacket 666 | #endif 667 | addEncoded Nothing = do resetPacket 668 | encode_video_check ctx pkt Nothing >>= 669 | flip when (writePacket >> addEncoded Nothing) 670 | addEncoded (Just srcImg@(srcFmt, V2 srcW srcH, pixels)) = 671 | do resetPacket 672 | when (not $ checkPalCompat srcImg) 673 | (error $ 674 | unlines [ "Palettized output requires source images to be the " 675 | , "same resolution as the output video" ]) 676 | let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer 677 | sws' <- for sws $ \sPtr -> do 678 | s <- readIORef sPtr 679 | s' <- swsReset s (ImageInfo srcW srcH srcFmt) dstInfo 680 | swsBilinear 681 | writeIORef sPtr s' 682 | return s' 683 | timeStamp <- getCurrentFrameTimestamp 684 | setPts dstFrame timeStamp 685 | fillDst sws' (srcFmt, V2 srcW srcH, pixels') 686 | encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket 687 | -- Make sure the GC hasn't clobbered our palettized pixel data 688 | let (fp,_,_) = V.unsafeToForeignPtr pixels' 689 | touchForeignPtr fp 690 | #if LIBAVFORMAT_VERSION_MAJOR < 57 691 | addFrame = if isRaw then addRaw else addEncoded 692 | #else 693 | addFrame = addEncoded 694 | #endif 695 | go Nothing = do addFrame Nothing 696 | writeClose 697 | _ <- codec_close ctx 698 | with dstFrame av_frame_free 699 | av_free (getPtr pkt) 700 | avio_close_check oc 701 | avformat_free_context oc 702 | go img@(Just _) = addFrame img 703 | return go 704 | 705 | initializeAudio :: AVStream 706 | -> AVCodec 707 | -> AVCodecContext 708 | -> IO (Maybe AVFrame -> IO ()) 709 | initializeAudio st codec ctx = do 710 | if audioCodecId /= avCodecIdNone 711 | then do 712 | pkt <- av_packet_alloc 713 | init_packet pkt 714 | 715 | frameNum <- newIORef (0::Int) 716 | timeBase <- getTimeBase ctx 717 | 718 | lastPts <- newIORef 0 719 | 720 | let read_pkts = do 721 | ret <- avcodec_receive_packet ctx pkt 722 | -- TODO: Distinguish between temp and permanent errors with EAGAIN 723 | if ret /= 0 724 | then return () 725 | else do 726 | timeBase2 <- getTimeBase st 727 | packet_rescale_ts pkt timeBase timeBase2 728 | setStreamIndex pkt =<< getStreamIndex st 729 | -- TODO: Not sure this pts will be exactly accurate. 730 | -- Also, we need to set duration too because it doesn't seem to be set. 731 | setPts pkt =<< readIORef lastPts 732 | runWithError "Error while writing audio frame" 733 | (av_interleaved_write_frame oc pkt) 734 | return () 735 | writeAudioFrame :: Maybe AVFrame -> IO () 736 | writeAudioFrame Nothing = do 737 | read_pkts 738 | writeClose 739 | codec_close ctx 740 | return () 741 | writeAudioFrame (Just frame) = writeAudioFrame' frame 742 | 743 | writeAudioFrame' :: AVFrame -> IO () 744 | writeAudioFrame' frame = do 745 | numSamples <- getNumSamples frame 746 | sampleRate <- getSampleRate ctx 747 | 748 | onGoingSampleCount <- readIORef frameNum 749 | let samplesCount = av_rescale_q (fromIntegral onGoingSampleCount) 750 | (AVRational 1 sampleRate) timeBase 751 | setPts frame (av_rescale_q samplesCount (AVRational 1 sampleRate) timeBase) 752 | newPts <- getPts frame 753 | modifyIORef lastPts (const newPts) 754 | modifyIORef frameNum (+ fromIntegral numSamples) 755 | 756 | runWithError "Error encoding audio" 757 | (avcodec_send_frame ctx frame) 758 | read_pkts 759 | return writeAudioFrame 760 | else 761 | return $ \_ -> return () 762 | 763 | videoWriter <- case mVideoStream of 764 | Just (vs, ctx) -> 765 | withVideoParams sp (return (\_ -> return ())) 766 | (initializeVideo vs ctx) 767 | Nothing -> return (\_ -> return ()) 768 | audioWriter <- case mAudioStream of 769 | Just (as, codec, ctx) -> 770 | withAudioParams sp (return $ \_ -> return ()) 771 | (const (initializeAudio as codec ctx)) 772 | Nothing -> return $ \_ -> return () 773 | 774 | return $ AVWriterContext 775 | { avwVideoCodecContext = snd <$> mVideoStream 776 | , avwAudioCodecContext = (\(_, _, ctx) -> ctx) <$> mAudioStream 777 | , avwVideoWriter = videoWriter 778 | , avwAudioWriter = audioWriter 779 | } 780 | 781 | -- | Open a target file for writing a video stream. The function 782 | -- returned may be used to write RGB images of the resolution given by 783 | -- the provided 'EncodingParams' (i.e. the same resolution as the 784 | -- output video). If this function is applied to 'Nothing', then the 785 | -- output stream is closed. Note that 'Nothing' /must/ be provided to 786 | -- properly terminate video encoding. Throws an error if you do not 787 | -- provide a 'EncodingParams' without 'VideoParams' 788 | frameWriterRgb :: EncodingParams -> FilePath 789 | -> IO (Maybe (Vector CUChar) -> IO ()) 790 | frameWriterRgb ep f = do 791 | let aux pixels = (avPixFmtRgb24, V2 (epWidth ep) (epHeight ep), pixels) 792 | videoWriter <- frameWriter ep f 793 | return $ \pix -> videoWriter (aux <$> pix) 794 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Enums.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Codec.FFmpeg.Enums where 3 | import Data.Bits (Bits) 4 | import Foreign.C.Types 5 | import Foreign.Storable (Storable) 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include "nameCompat.h" 15 | 16 | newtype AVMediaType = AVMediaType CInt deriving (Eq, Storable) 17 | #enum AVMediaType,AVMediaType \ 18 | , AVMEDIA_TYPE_VIDEO\ 19 | , AVMEDIA_TYPE_AUDIO\ 20 | , AVMEDIA_TYPE_DATA\ 21 | , AVMEDIA_TYPE_SUBTITLE\ 22 | , AVMEDIA_TYPE_ATTACHMENT\ 23 | , AVMEDIA_TYPE_NB 24 | 25 | newtype AVPixelFormat = AVPixelFormat CInt deriving (Eq, Storable) 26 | #enum AVPixelFormat,AVPixelFormat \ 27 | , AV_PIX_FMT_NONE\ 28 | , AV_PIX_FMT_RGB24\ 29 | , AV_PIX_FMT_RGBA\ 30 | , AV_PIX_FMT_BGRA\ 31 | , AV_PIX_FMT_Y400A\ 32 | , AV_PIX_FMT_RGB32\ 33 | , AV_PIX_FMT_RGB32_1\ 34 | , AV_PIX_FMT_BGR32\ 35 | , AV_PIX_FMT_BGR32_1\ 36 | , AV_PIX_FMT_RGB8\ 37 | , AV_PIX_FMT_BGR8\ 38 | , AV_PIX_FMT_RGB4_BYTE\ 39 | , AV_PIX_FMT_BGR4_BYTE\ 40 | , AV_PIX_FMT_GRAY8\ 41 | , AV_PIX_FMT_GRAY16\ 42 | , AV_PIX_FMT_GRAY8A\ 43 | , AV_PIX_FMT_PAL8\ 44 | , AV_PIX_FMT_RGB565\ 45 | , AV_PIX_FMT_RGB555\ 46 | , AV_PIX_FMT_YUV420P\ 47 | , AV_PIX_FMT_YUV420P9\ 48 | , AV_PIX_FMT_YUV420P10\ 49 | , AV_PIX_FMT_YUV420P12\ 50 | , AV_PIX_FMT_YUV422P12\ 51 | , AV_PIX_FMT_YUV444P12\ 52 | , AV_PIX_FMT_YUV420P14\ 53 | , AV_PIX_FMT_YUV422P14\ 54 | , AV_PIX_FMT_YUV444P14\ 55 | , AV_PIX_FMT_YUV420P16\ 56 | , AV_PIX_FMT_YUV422P16\ 57 | , AV_PIX_FMT_YUV444P16\ 58 | , AV_PIX_FMT_RGBA64\ 59 | , AV_PIX_FMT_BGRA64 60 | 61 | instance Show AVPixelFormat where 62 | show x 63 | | x == avPixFmtRgb24 = "AV_PIX_FMT_RGB24" 64 | | x == avPixFmtYuv420p = "AV_PIX_FMT_Y420P" 65 | | x == avPixFmtYuv422p12 = "AV_PIX_FMTYUV422P12" 66 | | x == avPixFmtYuv420p14 = "AV_PIX_FMTYUV422P12" 67 | | otherwise = let AVPixelFormat y = x 68 | in "Other pixel format: "++show y 69 | 70 | newtype AVCodecID = AVCodecID CInt deriving (Eq, Show, Storable) 71 | #enum AVCodecID,AVCodecID \ 72 | , AV_CODEC_ID_NONE\ 73 | , AV_CODEC_ID_MPEG1VIDEO\ 74 | , AV_CODEC_ID_MPEG2VIDEO\ 75 | , AV_CODEC_ID_H261\ 76 | , AV_CODEC_ID_H263\ 77 | , AV_CODEC_ID_RV10\ 78 | , AV_CODEC_ID_RV20\ 79 | , AV_CODEC_ID_MJPEG\ 80 | , AV_CODEC_ID_MJPEGB\ 81 | , AV_CODEC_ID_LJPEG\ 82 | , AV_CODEC_ID_SP5X\ 83 | , AV_CODEC_ID_JPEGLS\ 84 | , AV_CODEC_ID_MPEG4\ 85 | , AV_CODEC_ID_RAWVIDEO\ 86 | , AV_CODEC_ID_MSMPEG4V1\ 87 | , AV_CODEC_ID_MSMPEG4V2\ 88 | , AV_CODEC_ID_MSMPEG4V3\ 89 | , AV_CODEC_ID_WMV1\ 90 | , AV_CODEC_ID_WMV2\ 91 | , AV_CODEC_ID_H263P\ 92 | , AV_CODEC_ID_H263I\ 93 | , AV_CODEC_ID_FLV1\ 94 | , AV_CODEC_ID_SVQ1\ 95 | , AV_CODEC_ID_SVQ3\ 96 | , AV_CODEC_ID_DVVIDEO\ 97 | , AV_CODEC_ID_HUFFYUV\ 98 | , AV_CODEC_ID_CYUV\ 99 | , AV_CODEC_ID_H264\ 100 | , AV_CODEC_ID_INDEO3\ 101 | , AV_CODEC_ID_VP3\ 102 | , AV_CODEC_ID_THEORA\ 103 | , AV_CODEC_ID_ASV1\ 104 | , AV_CODEC_ID_ASV2\ 105 | , AV_CODEC_ID_FFV1\ 106 | , AV_CODEC_ID_4XM\ 107 | , AV_CODEC_ID_VCR1\ 108 | , AV_CODEC_ID_CLJR\ 109 | , AV_CODEC_ID_MDEC\ 110 | , AV_CODEC_ID_ROQ\ 111 | , AV_CODEC_ID_INTERPLAY_VIDEO\ 112 | , AV_CODEC_ID_XAN_WC3\ 113 | , AV_CODEC_ID_XAN_WC4\ 114 | , AV_CODEC_ID_RPZA\ 115 | , AV_CODEC_ID_CINEPAK\ 116 | , AV_CODEC_ID_WS_VQA\ 117 | , AV_CODEC_ID_MSRLE\ 118 | , AV_CODEC_ID_MSVIDEO1\ 119 | , AV_CODEC_ID_IDCIN\ 120 | , AV_CODEC_ID_8BPS\ 121 | , AV_CODEC_ID_SMC\ 122 | , AV_CODEC_ID_FLIC\ 123 | , AV_CODEC_ID_TRUEMOTION1\ 124 | , AV_CODEC_ID_VMDVIDEO\ 125 | , AV_CODEC_ID_MSZH\ 126 | , AV_CODEC_ID_ZLIB\ 127 | , AV_CODEC_ID_QTRLE\ 128 | , AV_CODEC_ID_TSCC\ 129 | , AV_CODEC_ID_ULTI\ 130 | , AV_CODEC_ID_QDRAW\ 131 | , AV_CODEC_ID_VIXL\ 132 | , AV_CODEC_ID_QPEG\ 133 | , AV_CODEC_ID_PNG\ 134 | , AV_CODEC_ID_PPM\ 135 | , AV_CODEC_ID_PBM\ 136 | , AV_CODEC_ID_PGM\ 137 | , AV_CODEC_ID_PGMYUV\ 138 | , AV_CODEC_ID_PAM\ 139 | , AV_CODEC_ID_FFVHUFF\ 140 | , AV_CODEC_ID_RV30\ 141 | , AV_CODEC_ID_RV40\ 142 | , AV_CODEC_ID_VC1\ 143 | , AV_CODEC_ID_WMV3\ 144 | , AV_CODEC_ID_LOCO\ 145 | , AV_CODEC_ID_WNV1\ 146 | , AV_CODEC_ID_AASC\ 147 | , AV_CODEC_ID_INDEO2\ 148 | , AV_CODEC_ID_FRAPS\ 149 | , AV_CODEC_ID_TRUEMOTION2\ 150 | , AV_CODEC_ID_BMP\ 151 | , AV_CODEC_ID_CSCD\ 152 | , AV_CODEC_ID_MMVIDEO\ 153 | , AV_CODEC_ID_ZMBV\ 154 | , AV_CODEC_ID_AVS\ 155 | , AV_CODEC_ID_SMACKVIDEO\ 156 | , AV_CODEC_ID_NUV\ 157 | , AV_CODEC_ID_KMVC\ 158 | , AV_CODEC_ID_FLASHSV\ 159 | , AV_CODEC_ID_CAVS\ 160 | , AV_CODEC_ID_JPEG2000\ 161 | , AV_CODEC_ID_VMNC\ 162 | , AV_CODEC_ID_VP5\ 163 | , AV_CODEC_ID_VP6\ 164 | , AV_CODEC_ID_VP6F\ 165 | , AV_CODEC_ID_TARGA\ 166 | , AV_CODEC_ID_DSICINVIDEO\ 167 | , AV_CODEC_ID_TIERTEXSEQVIDEO\ 168 | , AV_CODEC_ID_TIFF\ 169 | , AV_CODEC_ID_GIF\ 170 | , AV_CODEC_ID_DXA\ 171 | , AV_CODEC_ID_DNXHD\ 172 | , AV_CODEC_ID_THP\ 173 | , AV_CODEC_ID_SGI\ 174 | , AV_CODEC_ID_C93\ 175 | , AV_CODEC_ID_BETHSOFTVID\ 176 | , AV_CODEC_ID_PTX\ 177 | , AV_CODEC_ID_TXD\ 178 | , AV_CODEC_ID_VP6A\ 179 | , AV_CODEC_ID_AMV\ 180 | , AV_CODEC_ID_VB\ 181 | , AV_CODEC_ID_PCX\ 182 | , AV_CODEC_ID_SUNRAST\ 183 | , AV_CODEC_ID_INDEO4\ 184 | , AV_CODEC_ID_INDEO5\ 185 | , AV_CODEC_ID_MIMIC\ 186 | , AV_CODEC_ID_RL2\ 187 | , AV_CODEC_ID_ESCAPE124\ 188 | , AV_CODEC_ID_DIRAC\ 189 | , AV_CODEC_ID_BFI\ 190 | , AV_CODEC_ID_CMV\ 191 | , AV_CODEC_ID_MOTIONPIXELS\ 192 | , AV_CODEC_ID_TGV\ 193 | , AV_CODEC_ID_TGQ\ 194 | , AV_CODEC_ID_TQI\ 195 | , AV_CODEC_ID_AURA\ 196 | , AV_CODEC_ID_AURA2\ 197 | , AV_CODEC_ID_V210X\ 198 | , AV_CODEC_ID_TMV\ 199 | , AV_CODEC_ID_V210\ 200 | , AV_CODEC_ID_DPX\ 201 | , AV_CODEC_ID_MAD\ 202 | , AV_CODEC_ID_FRWU\ 203 | , AV_CODEC_ID_FLASHSV2\ 204 | , AV_CODEC_ID_CDGRAPHICS\ 205 | , AV_CODEC_ID_R210\ 206 | , AV_CODEC_ID_ANM\ 207 | , AV_CODEC_ID_BINKVIDEO\ 208 | , AV_CODEC_ID_IFF_ILBM\ 209 | , AV_CODEC_ID_KGV1\ 210 | , AV_CODEC_ID_YOP\ 211 | , AV_CODEC_ID_VP8\ 212 | , AV_CODEC_ID_PICTOR\ 213 | , AV_CODEC_ID_ANSI\ 214 | , AV_CODEC_ID_A64_MULTI\ 215 | , AV_CODEC_ID_A64_MULTI5\ 216 | , AV_CODEC_ID_R10K\ 217 | , AV_CODEC_ID_MXPEG\ 218 | , AV_CODEC_ID_LAGARITH\ 219 | , AV_CODEC_ID_PRORES\ 220 | , AV_CODEC_ID_JV\ 221 | , AV_CODEC_ID_DFA\ 222 | , AV_CODEC_ID_WMV3IMAGE\ 223 | , AV_CODEC_ID_VC1IMAGE\ 224 | , AV_CODEC_ID_UTVIDEO\ 225 | , AV_CODEC_ID_BMV_VIDEO\ 226 | , AV_CODEC_ID_VBLE\ 227 | , AV_CODEC_ID_DXTORY\ 228 | , AV_CODEC_ID_V410\ 229 | , AV_CODEC_ID_XWD\ 230 | , AV_CODEC_ID_CDXL\ 231 | , AV_CODEC_ID_XBM\ 232 | , AV_CODEC_ID_ZEROCODEC\ 233 | , AV_CODEC_ID_MSS1\ 234 | , AV_CODEC_ID_MSA1\ 235 | , AV_CODEC_ID_TSCC2\ 236 | , AV_CODEC_ID_MTS2\ 237 | , AV_CODEC_ID_CLLC\ 238 | , AV_CODEC_ID_MSS2\ 239 | , AV_CODEC_ID_VP9\ 240 | , AV_CODEC_ID_AIC\ 241 | , AV_CODEC_ID_ESCAPE130\ 242 | , AV_CODEC_ID_G2M\ 243 | , AV_CODEC_ID_WEBP\ 244 | , AV_CODEC_ID_HNM4_VIDEO\ 245 | , AV_CODEC_ID_HEVC\ 246 | , AV_CODEC_ID_MP2\ 247 | , AV_CODEC_ID_MP3\ 248 | , AV_CODEC_ID_AAC\ 249 | , AV_CODEC_ID_AC3\ 250 | , AV_CODEC_ID_DTS\ 251 | , AV_CODEC_ID_VORBIS\ 252 | , AV_CODEC_ID_DVAUDIO\ 253 | , AV_CODEC_ID_WMAV1\ 254 | , AV_CODEC_ID_WMAV2\ 255 | , AV_CODEC_ID_MACE3\ 256 | , AV_CODEC_ID_MACE6\ 257 | , AV_CODEC_ID_VMDAUDIO\ 258 | , AV_CODEC_ID_FLAC\ 259 | , AV_CODEC_ID_MP3ADU\ 260 | , AV_CODEC_ID_MP3ON4\ 261 | , AV_CODEC_ID_SHORTEN\ 262 | , AV_CODEC_ID_ALAC\ 263 | , AV_CODEC_ID_WESTWOOD_SND1\ 264 | , AV_CODEC_ID_GSM\ 265 | , AV_CODEC_ID_QDM2\ 266 | , AV_CODEC_ID_COOK\ 267 | , AV_CODEC_ID_TRUESPEECH\ 268 | , AV_CODEC_ID_TTA\ 269 | , AV_CODEC_ID_SMACKAUDIO\ 270 | , AV_CODEC_ID_QCELP\ 271 | , AV_CODEC_ID_WAVPACK\ 272 | , AV_CODEC_ID_DSICINAUDIO\ 273 | , AV_CODEC_ID_IMC\ 274 | , AV_CODEC_ID_MUSEPACK7\ 275 | , AV_CODEC_ID_MLP\ 276 | , AV_CODEC_ID_GSM_MS\ 277 | , AV_CODEC_ID_ATRAC3\ 278 | , AV_CODEC_ID_APE\ 279 | , AV_CODEC_ID_NELLYMOSER\ 280 | , AV_CODEC_ID_MUSEPACK8\ 281 | , AV_CODEC_ID_SPEEX\ 282 | , AV_CODEC_ID_WMAVOICE\ 283 | , AV_CODEC_ID_WMAPRO\ 284 | , AV_CODEC_ID_WMALOSSLESS\ 285 | , AV_CODEC_ID_ATRAC3P\ 286 | , AV_CODEC_ID_EAC3\ 287 | , AV_CODEC_ID_SIPR\ 288 | , AV_CODEC_ID_MP1\ 289 | , AV_CODEC_ID_TWINVQ\ 290 | , AV_CODEC_ID_TRUEHD\ 291 | , AV_CODEC_ID_MP4ALS\ 292 | , AV_CODEC_ID_ATRAC1\ 293 | , AV_CODEC_ID_BINKAUDIO_RDFT\ 294 | , AV_CODEC_ID_BINKAUDIO_DCT\ 295 | , AV_CODEC_ID_AAC_LATM\ 296 | , AV_CODEC_ID_QDMC\ 297 | , AV_CODEC_ID_CELT\ 298 | , AV_CODEC_ID_G723_1\ 299 | , AV_CODEC_ID_G729\ 300 | , AV_CODEC_ID_8SVX_EXP\ 301 | , AV_CODEC_ID_8SVX_FIB\ 302 | , AV_CODEC_ID_BMV_AUDIO\ 303 | , AV_CODEC_ID_RALF\ 304 | , AV_CODEC_ID_IAC\ 305 | , AV_CODEC_ID_ILBC\ 306 | , AV_CODEC_ID_OPUS\ 307 | , AV_CODEC_ID_COMFORT_NOISE\ 308 | , AV_CODEC_ID_TAK\ 309 | , AV_CODEC_ID_METASOUND\ 310 | , AV_CODEC_ID_PAF_AUDIO\ 311 | , AV_CODEC_ID_ON2AVC\ 312 | , AV_CODEC_ID_DSS_SP\ 313 | , AV_CODEC_ID_FFWAVESYNTH\ 314 | , AV_CODEC_ID_SONIC\ 315 | , AV_CODEC_ID_SONIC_LS\ 316 | , AV_CODEC_ID_EVRC\ 317 | , AV_CODEC_ID_SMV\ 318 | , AV_CODEC_ID_DSD_LSBF\ 319 | , AV_CODEC_ID_DSD_MSBF\ 320 | , AV_CODEC_ID_DSD_LSBF_PLANAR\ 321 | , AV_CODEC_ID_DSD_MSBF_PLANAR\ 322 | , AV_CODEC_ID_4GV\ 323 | , AV_CODEC_ID_INTERPLAY_ACM\ 324 | , AV_CODEC_ID_XMA1\ 325 | , AV_CODEC_ID_XMA2\ 326 | , AV_CODEC_ID_DST 327 | 328 | 329 | newtype SwsAlgorithm = SwsAlgorithm CUInt deriving (Eq, Show, Storable) 330 | #enum SwsAlgorithm,SwsAlgorithm \ 331 | , SWS_FAST_BILINEAR\ 332 | , SWS_BILINEAR\ 333 | , SWS_BICUBIC\ 334 | , SWS_X\ 335 | , SWS_POINT\ 336 | , SWS_AREA\ 337 | , SWS_BICUBLIN\ 338 | , SWS_GAUSS\ 339 | , SWS_SINC\ 340 | , SWS_LANCZOS\ 341 | , SWS_SPLINE 342 | 343 | newtype FFProfile = FFProfile CInt deriving (Eq, Storable) 344 | #enum FFProfile, FFProfile \ 345 | , FF_PROFILE_AAC_MAIN\ 346 | , FF_PROFILE_AAC_LOW\ 347 | , FF_PROFILE_AAC_SSR\ 348 | , FF_PROFILE_AAC_LTP\ 349 | , FF_PROFILE_AAC_HE\ 350 | , FF_PROFILE_AAC_HE_V2\ 351 | , FF_PROFILE_AAC_LD\ 352 | , FF_PROFILE_AAC_ELD\ 353 | , FF_PROFILE_MPEG2_AAC_LOW\ 354 | , FF_PROFILE_MPEG2_AAC_HE\ 355 | , FF_PROFILE_DTS\ 356 | , FF_PROFILE_DTS_ES\ 357 | , FF_PROFILE_DTS_96_24\ 358 | , FF_PROFILE_DTS_HD_HRA\ 359 | , FF_PROFILE_DTS_HD_MA\ 360 | , FF_PROFILE_MPEG2_422\ 361 | , FF_PROFILE_MPEG2_HIGH\ 362 | , FF_PROFILE_MPEG2_SS\ 363 | , FF_PROFILE_MPEG2_SNR_SCALABLE\ 364 | , FF_PROFILE_MPEG2_MAIN\ 365 | , FF_PROFILE_MPEG2_SIMPLE\ 366 | , FF_PROFILE_H264_CONSTRAINED\ 367 | , FF_PROFILE_H264_INTRA\ 368 | , FF_PROFILE_H264_BASELINE\ 369 | , FF_PROFILE_H264_CONSTRAINED_BASELINE\ 370 | , FF_PROFILE_H264_MAIN\ 371 | , FF_PROFILE_H264_EXTENDED\ 372 | , FF_PROFILE_H264_HIGH\ 373 | , FF_PROFILE_H264_HIGH_10\ 374 | , FF_PROFILE_H264_HIGH_10_INTRA\ 375 | , FF_PROFILE_H264_HIGH_422\ 376 | , FF_PROFILE_H264_HIGH_422_INTRA\ 377 | , FF_PROFILE_H264_HIGH_444\ 378 | , FF_PROFILE_H264_HIGH_444_PREDICTIVE\ 379 | , FF_PROFILE_H264_HIGH_444_INTRA\ 380 | , FF_PROFILE_H264_CAVLC_444\ 381 | , FF_PROFILE_VC1_SIMPLE\ 382 | , FF_PROFILE_VC1_MAIN\ 383 | , FF_PROFILE_VC1_COMPLEX\ 384 | , FF_PROFILE_VC1_ADVANCED\ 385 | , FF_PROFILE_MPEG4_SIMPLE\ 386 | , FF_PROFILE_MPEG4_SIMPLE_SCALABLE\ 387 | , FF_PROFILE_MPEG4_CORE\ 388 | , FF_PROFILE_MPEG4_MAIN\ 389 | , FF_PROFILE_MPEG4_N_BIT\ 390 | , FF_PROFILE_MPEG4_SCALABLE_TEXTURE\ 391 | , FF_PROFILE_MPEG4_SIMPLE_FACE_ANIMATION\ 392 | , FF_PROFILE_MPEG4_BASIC_ANIMATED_TEXTURE\ 393 | , FF_PROFILE_MPEG4_HYBRID\ 394 | , FF_PROFILE_MPEG4_ADVANCED_REAL_TIME\ 395 | , FF_PROFILE_MPEG4_CORE_SCALABLE\ 396 | , FF_PROFILE_MPEG4_ADVANCED_CODING\ 397 | , FF_PROFILE_MPEG4_ADVANCED_CORE\ 398 | , FF_PROFILE_MPEG4_ADVANCED_SCALABLE_TEXTURE\ 399 | , FF_PROFILE_MPEG4_SIMPLE_STUDIO\ 400 | , FF_PROFILE_MPEG4_ADVANCED_SIMPLE 401 | 402 | newtype AVIOFlag = AVIOFlag CInt deriving (Eq, Storable) 403 | #enum AVIOFlag, AVIOFlag \ 404 | , AVIO_FLAG_READ\ 405 | , AVIO_FLAG_WRITE\ 406 | , AVIO_FLAG_READ_WRITE\ 407 | , AVIO_FLAG_NONBLOCK\ 408 | , AVIO_FLAG_DIRECT 409 | 410 | newtype AVRoundMode = AVRoundMode CInt deriving (Eq, Storable) 411 | #enum AVRoundMode, AVRoundMode \ 412 | , AV_ROUND_ZERO\ 413 | , AV_ROUND_INF\ 414 | , AV_ROUND_DOWN\ 415 | , AV_ROUND_UP\ 416 | , AV_ROUND_NEAR_INF\ 417 | , AV_ROUND_PASS_MINMAX 418 | 419 | newtype CodecFlag = CodecFlag CInt deriving (Eq, Bits, Storable) 420 | #if LIBAVCODEC_VERSION_MAJOR < 57 421 | #enum CodecFlag, CodecFlag \ 422 | , CODEC_FLAG_UNALIGNED\ 423 | , CODEC_FLAG_QSCALE\ 424 | , CODEC_FLAG_4MV\ 425 | , CODEC_FLAG_OUTPUT_CORRUPT\ 426 | , CODEC_FLAG_QPEL\ 427 | , CODEC_FLAG_GMC\ 428 | , CODEC_FLAG_MV0\ 429 | , CODEC_FLAG_INPUT_PRESERVED\ 430 | , CODEC_FLAG_PASS1\ 431 | , CODEC_FLAG_PASS2\ 432 | , CODEC_FLAG_GRAY\ 433 | , CODEC_FLAG_EMU_EDGE\ 434 | , CODEC_FLAG_PSNR\ 435 | , CODEC_FLAG_TRUNCATED\ 436 | , CODEC_FLAG_NORMALIZE_AQP\ 437 | , CODEC_FLAG_INTERLACED_DCT\ 438 | , CODEC_FLAG_LOW_DELAY\ 439 | , CODEC_FLAG_GLOBAL_HEADER\ 440 | , CODEC_FLAG_BITEXACT\ 441 | , CODEC_FLAG_AC_PRED\ 442 | , CODEC_FLAG_LOOP_FILTER\ 443 | , CODEC_FLAG_INTERLACED_ME\ 444 | , CODEC_FLAG_CLOSED_GOP 445 | #else 446 | #enum CodecFlag, CodecFlag \ 447 | , AV_CODEC_FLAG_UNALIGNED\ 448 | , AV_CODEC_FLAG_QSCALE\ 449 | , AV_CODEC_FLAG_4MV\ 450 | , AV_CODEC_FLAG_OUTPUT_CORRUPT\ 451 | , AV_CODEC_FLAG_QPEL\ 452 | , AV_CODEC_FLAG_PASS1\ 453 | , AV_CODEC_FLAG_PASS2\ 454 | , AV_CODEC_FLAG_LOOP_FILTER\ 455 | , AV_CODEC_FLAG_GRAY\ 456 | , AV_CODEC_FLAG_PSNR\ 457 | , AV_CODEC_FLAG_TRUNCATED\ 458 | , AV_CODEC_FLAG_INTERLACED_DCT\ 459 | , AV_CODEC_FLAG_LOW_DELAY\ 460 | , AV_CODEC_FLAG_GLOBAL_HEADER\ 461 | , AV_CODEC_FLAG_BITEXACT\ 462 | , AV_CODEC_FLAG_AC_PRED\ 463 | , AV_CODEC_FLAG_INTERLACED_ME\ 464 | , AV_CODEC_FLAG_CLOSED_GOP 465 | #endif 466 | 467 | newtype FormatFlag = FormatFlag CInt deriving (Eq, Bits, Storable) 468 | #if LIBAVCODEC_VERSION_MAJOR < 57 469 | #enum FormatFlag, FormatFlag \ 470 | , AVFMT_NOFILE\ 471 | , AVFMT_NEEDNUMBER\ 472 | , AVFMT_RAWPICTURE\ 473 | , AVFMT_GLOBALHEADER\ 474 | , AVFMT_NOTIMESTAMPS\ 475 | , AVFMT_VARIABLE_FPS\ 476 | , AVFMT_NODIMENSIONS\ 477 | , AVFMT_NOSTREAMS\ 478 | , AVFMT_ALLOW_FLUSH\ 479 | , AVFMT_TS_NONSTRICT 480 | #else 481 | #enum FormatFlag, FormatFlag \ 482 | , AVFMT_NOFILE\ 483 | , AVFMT_NEEDNUMBER\ 484 | , AVFMT_GLOBALHEADER\ 485 | , AVFMT_NOTIMESTAMPS\ 486 | , AVFMT_VARIABLE_FPS\ 487 | , AVFMT_NODIMENSIONS\ 488 | , AVFMT_NOSTREAMS\ 489 | , AVFMT_NOBINSEARCH\ 490 | , AVFMT_NOGENSEARCH\ 491 | , AVFMT_NO_BYTE_SEEK\ 492 | , AVFMT_ALLOW_FLUSH\ 493 | , AVFMT_TS_NONSTRICT\ 494 | , AVFMT_TS_NEGATIVE\ 495 | , AVFMT_SEEK_TO_PTS 496 | #endif 497 | 498 | newtype PacketFlag = PacketFlag CInt deriving (Eq, Bits, Storable) 499 | #enum PacketFlag, PacketFlag \ 500 | , AV_PKT_FLAG_KEY\ 501 | , AV_PKT_FLAG_CORRUPT 502 | 503 | newtype LogLevel = LogLevel CInt deriving (Eq, Bits, Storable) 504 | #enum LogLevel, LogLevel \ 505 | , AV_LOG_QUIET\ 506 | , AV_LOG_PANIC\ 507 | , AV_LOG_FATAL\ 508 | , AV_LOG_ERROR\ 509 | , AV_LOG_WARNING\ 510 | , AV_LOG_INFO\ 511 | , AV_LOG_VERBOSE\ 512 | , AV_LOG_DEBUG\ 513 | , AV_LOG_TRACE\ 514 | , AV_LOG_MAX_OFFSET 515 | 516 | newtype AVSampleFormat = AVSampleFormat CInt deriving (Eq, Bits, Storable) 517 | #enum AVSampleFormat, AVSampleFormat \ 518 | , AV_SAMPLE_FMT_NONE\ 519 | , AV_SAMPLE_FMT_U8\ 520 | , AV_SAMPLE_FMT_S16\ 521 | , AV_SAMPLE_FMT_S32\ 522 | , AV_SAMPLE_FMT_FLT\ 523 | , AV_SAMPLE_FMT_DBL\ 524 | , AV_SAMPLE_FMT_U8P\ 525 | , AV_SAMPLE_FMT_S16P\ 526 | , AV_SAMPLE_FMT_S32P\ 527 | , AV_SAMPLE_FMT_FLTP\ 528 | , AV_SAMPLE_FMT_DBLP\ 529 | , AV_SAMPLE_FMT_NB 530 | 531 | getSampleFormatInt :: AVSampleFormat -> CInt 532 | getSampleFormatInt (AVSampleFormat i) = i 533 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Internal/Debug.hsc: -------------------------------------------------------------------------------- 1 | -- | Helpers for dumping information about codecs to stdout. 2 | module Codec.FFmpeg.Internal.Debug where 3 | import Codec.FFmpeg.Enums 4 | import Codec.FFmpeg.Types 5 | import Control.Monad (when, (>=>)) 6 | import Foreign.C.String 7 | import Foreign.C.Types 8 | import Foreign.Marshal.Array (advancePtr) 9 | import Foreign.Ptr (nullPtr) 10 | import Foreign.Storable 11 | 12 | #include 13 | #include 14 | 15 | -- | FFmpeg's built-in format debug utlity. 16 | foreign import ccall "av_dump_format" 17 | av_dump_format :: AVFormatContext -> CInt -> CString -> CInt -> IO () 18 | 19 | -- | Print the short name, long name, and ID of a codec. 20 | debugCodec :: AVCodec -> IO () 21 | debugCodec cod = do 22 | longName <- getLongName cod >>= peekCString 23 | shortName <- getName cod >>= peekCString 24 | cid <- getCodecID cod 25 | putStrLn $ "Codec short_name = " ++ show shortName 26 | putStrLn $ "Codec long_name = " ++ show longName 27 | putStrLn $ "Codec ID = " ++ show cid 28 | 29 | -- | Print various codec settings. 30 | debugCodecContext :: AVCodecContext -> IO() 31 | debugCodecContext (AVCodecContext p) = do 32 | putStrLn "*** AVCodecContext dump:" 33 | (#peek AVCodecContext, profile) p >>= si "profile" 34 | (#peek AVCodecContext, flags) p >>= si "flags" 35 | (#peek AVCodecContext, flags2) p >>= si "flags2" 36 | (#peek AVCodecContext, gop_size) p >>= si "gop_size" 37 | (#peek AVCodecContext, bit_rate) p >>= si "bit_rate" 38 | (#peek AVCodecContext, max_b_frames) p >>= si "max_b_frames" 39 | (#peek AVCodecContext, b_frame_strategy) p >>= si "b_frame_strategy" 40 | (#peek AVCodecContext, qmin) p >>= si "qmin" 41 | (#peek AVCodecContext, qmax) p >>= si "qmax" 42 | (#peek AVCodecContext, me_cmp) p >>= si "me_cmp" 43 | (#peek AVCodecContext, me_range) p >>= si "me_range" 44 | putStrLn "" 45 | where si msg = putStrLn . ((msg++" = ")++) . show :: CInt -> IO () 46 | 47 | foreign import ccall "av_get_pix_fmt_name" 48 | av_get_pix_fmt_name :: AVPixelFormat -> IO CString 49 | 50 | pixFmtName :: AVPixelFormat -> IO String 51 | pixFmtName = av_get_pix_fmt_name >=> peekCString 52 | 53 | -- | Print all pixel formats supported by a given 'AVCodec'. 54 | debugPixelFormats :: AVCodec -> IO () 55 | debugPixelFormats cod = putStrLn "Supported pixel formats:" >> 56 | getPixelFormats cod >>= go 0 57 | where go i fmts 58 | = let ptr = advancePtr fmts i 59 | in when (ptr /= nullPtr) $ do 60 | fmt <- peek ptr 61 | when (fmt /= avPixFmtNone) $ do 62 | av_get_pix_fmt_name fmt >>= peekCString >>= 63 | putStrLn . (" " ++) 64 | go (i+1) fmts 65 | 66 | foreign import ccall "avcodec_get_name" 67 | avcodec_get_name :: AVCodecID -> IO CString 68 | 69 | -- | Get the name of a codec. 70 | debugCodecName :: AVCodecID -> IO String 71 | debugCodecName = avcodec_get_name >=> peekCString 72 | 73 | foreign import ccall "av_get_sample_fmt_name" 74 | av_get_sample_fmt_name :: AVSampleFormat -> IO CString 75 | 76 | debugSampleFmtName :: AVSampleFormat -> IO String 77 | debugSampleFmtName = av_get_sample_fmt_name >=> peekCString 78 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Internal/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- | Minimal operations on small vector types. 3 | module Codec.FFmpeg.Internal.Linear where 4 | import Foreign.C.Types 5 | import Foreign.Ptr (castPtr) 6 | import Foreign.Storable 7 | 8 | -- | A two-component vector 9 | data V2 a = V2 !a !a 10 | 11 | -- | A three-component vector 12 | data V3 a = V3 !a !a !a 13 | 14 | instance Functor V3 where 15 | fmap f (V3 x y z) = V3 (f x) (f y) (f z) 16 | 17 | instance Storable a => Storable (V3 a) where 18 | sizeOf _ = 3 * sizeOf (undefined::a) 19 | alignment _ = alignment (undefined::a) 20 | peek ptr = let ptr' = castPtr ptr 21 | in V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 22 | poke ptr (V3 x y z) = let ptr' = castPtr ptr 23 | in do poke ptr' x 24 | pokeElemOff ptr' 1 y 25 | pokeElemOff ptr' 2 z 26 | 27 | -- | Quadrance between two 3D points. 28 | qd :: V3 CInt -> V3 CInt -> CInt 29 | qd (V3 x1 y1 z1) (V3 x2 y2 z2) = let dx = x2 - x1 30 | dy = y2 - y1 31 | dz = z2 - z1 32 | in dx * dx + dy * dy + dz * dz 33 | 34 | -- | A four-component vector 35 | data V4 a = V4 !a !a !a !a 36 | 37 | instance Functor V4 where 38 | fmap f (V4 x y z w) = V4 (f x) (f y) (f z) (f w) 39 | 40 | instance Storable a => Storable (V4 a) where 41 | sizeOf _ = 4 * sizeOf (undefined::a) 42 | alignment _ = alignment (undefined::a) 43 | peek ptr = let ptr' = castPtr ptr 44 | in V4 <$> peek ptr' <*> peekElemOff ptr' 1 45 | <*> peekElemOff ptr' 2 <*> peekElemOff ptr' 3 46 | poke ptr (V4 x y z w) = let ptr' = castPtr ptr 47 | in do poke ptr' x 48 | pokeElemOff ptr' 1 y 49 | pokeElemOff ptr' 2 z 50 | pokeElemOff ptr' 3 w 51 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Juicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeSynonymInstances #-} 2 | -- | Convert between FFmpeg frames and JuicyPixels images. 3 | module Codec.FFmpeg.Juicy where 4 | import Codec.Picture 5 | import Codec.FFmpeg.Common 6 | import Codec.FFmpeg.Decode 7 | import Codec.FFmpeg.Encode 8 | import Codec.FFmpeg.Enums 9 | import Codec.FFmpeg.Internal.Linear (V2(..)) 10 | import Codec.FFmpeg.Types 11 | import Control.Arrow (first) 12 | import Control.Monad ((>=>), guard) 13 | import Control.Monad.Except 14 | import Control.Monad.IO.Class (MonadIO) 15 | import Control.Monad.Trans.Class (lift) 16 | import Control.Monad.Trans.Maybe 17 | import Data.Foldable (traverse_) 18 | import qualified Data.Vector.Storable as V 19 | import qualified Data.Vector.Storable.Mutable as VM 20 | import Foreign.C.Types 21 | import Foreign.Storable (sizeOf) 22 | import Data.Maybe (maybe) 23 | 24 | 25 | -- | Convert 'AVFrame' to a 'Vector'. 26 | frameToVector :: AVFrame -> IO (Maybe (V.Vector CUChar)) 27 | frameToVector = runMaybeT . frameToVectorT 28 | 29 | 30 | -- | Convert 'AVFrame' to a 'Vector' with the result in the 'MaybeT' transformer. 31 | frameToVectorT :: AVFrame -> MaybeT IO (V.Vector CUChar) 32 | frameToVectorT frame = do 33 | 34 | bufSize <- fromIntegral <$> frameBufferSizeT frame 35 | 36 | v <- MaybeT $ do 37 | 38 | v <- VM.new bufSize 39 | 40 | VM.unsafeWith v (frameCopyToBuffer frame) 41 | >>= return . maybe Nothing (const (Just v)) 42 | 43 | lift $ V.unsafeFreeze v 44 | 45 | 46 | -- | Convert an 'AVFrame' to a 'DynamicImage' with the result in the 47 | -- 'MaybeT' transformer. 48 | -- 49 | -- > toJuicyT = MaybeT . toJuicy 50 | toJuicyT :: AVFrame -> MaybeT IO DynamicImage 51 | toJuicyT = MaybeT . toJuicy 52 | 53 | 54 | -- | Convert an 'AVFrame' to a 'DynamicImage'. 55 | toJuicy :: AVFrame -> IO (Maybe DynamicImage) 56 | toJuicy frame = runMaybeT $ do 57 | 58 | v <- frameToVectorT frame 59 | 60 | MaybeT $ do 61 | 62 | w <- fromIntegral <$> getWidth frame 63 | h <- fromIntegral <$> getHeight frame 64 | 65 | let mkImage :: V.Storable (PixelBaseComponent a) 66 | => (Image a -> DynamicImage) -> Maybe DynamicImage 67 | mkImage c = Just $ c (Image w h (V.unsafeCast v)) 68 | 69 | fmt <- getPixelFormat frame 70 | 71 | return $ case () of 72 | _ | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 73 | | fmt == avPixFmtGray8 -> mkImage ImageY8 74 | | fmt == avPixFmtGray16 -> mkImage ImageY16 75 | | otherwise -> Nothing 76 | 77 | 78 | -- | Convert an 'AVFrame' to an 'Image'. 79 | toJuicyImage :: forall p. JuicyPixelFormat p => AVFrame -> IO (Maybe (Image p)) 80 | toJuicyImage frame = runMaybeT $ do 81 | 82 | fmt <- lift $ getPixelFormat frame 83 | guard (fmt == juicyPixelFormat ([] :: [p])) 84 | 85 | MaybeT $ do 86 | 87 | w <- fromIntegral <$> getWidth frame 88 | h <- fromIntegral <$> getHeight frame 89 | 90 | fmap (Image w h . V.unsafeCast) <$> frameToVector frame 91 | 92 | 93 | -- | Save an 'AVFrame' to a PNG file on disk assuming the frame could 94 | -- be converted to a 'DynamicImage' using 'toJuicy'. 95 | saveJuicy :: FilePath -> AVFrame -> IO () 96 | saveJuicy name = toJuicy >=> traverse_ (savePngImage name) 97 | 98 | 99 | -- | Mapping of @JuicyPixels@ pixel types to FFmpeg pixel formats. 100 | class Pixel a => JuicyPixelFormat a where 101 | juicyPixelFormat :: proxy a -> AVPixelFormat 102 | 103 | instance JuicyPixelFormat Pixel8 where 104 | juicyPixelFormat _ = avPixFmtGray8 105 | 106 | instance JuicyPixelFormat PixelRGB8 where 107 | juicyPixelFormat _ = avPixFmtRgb24 108 | 109 | instance JuicyPixelFormat PixelRGBA8 where 110 | juicyPixelFormat _ = avPixFmtRgba 111 | 112 | -- | Bytes-per-pixel for a JuicyPixels 'Pixel' type. 113 | juicyPixelStride :: forall a proxy. Pixel a => proxy a -> Int 114 | juicyPixelStride _ = 115 | sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a) 116 | 117 | -- | Read frames from a video stream. 118 | imageReaderT :: forall m p. 119 | (Functor m, MonadIO m, MonadError String m, 120 | JuicyPixelFormat p) 121 | => InputSource -> m (IO (Maybe (Image p)), IO ()) 122 | imageReaderT = fmap (first (runMaybeT . aux toJuicyImage)) 123 | . frameReader (juicyPixelFormat ([] :: [p])) 124 | where aux g x = MaybeT x >>= MaybeT . g 125 | 126 | -- | Read frames from a video stream. Errors are thrown as 127 | -- 'IOException's. 128 | imageReader :: JuicyPixelFormat p 129 | => InputSource -> IO (IO (Maybe (Image p)), IO ()) 130 | imageReader = (>>= either error return) . runExceptT . imageReaderT 131 | 132 | -- | Read time stamped frames from a video stream. Time is given in 133 | -- seconds from the start of the stream. 134 | imageReaderTimeT :: forall m p. 135 | (Functor m, MonadIO m, MonadError String m, 136 | JuicyPixelFormat p) 137 | => InputSource -> m (IO (Maybe (Image p, Double)), IO ()) 138 | imageReaderTimeT = fmap (first (runMaybeT . aux toJuicyImage)) 139 | . frameReaderTime (juicyPixelFormat ([] :: [p])) 140 | where aux g x = do (f,t) <- MaybeT x 141 | f' <- MaybeT $ g f 142 | return (f', t) 143 | 144 | -- | Read time stamped frames from a video stream. Time is given in 145 | -- seconds from the start of the stream. Errors are thrown as 146 | -- 'IOException's. 147 | imageReaderTime :: JuicyPixelFormat p 148 | => InputSource -> IO (IO (Maybe (Image p, Double)), IO ()) 149 | imageReaderTime = (>>= either error return) . runExceptT . imageReaderTimeT 150 | 151 | -- | Open a target file for writing a video stream. When the returned 152 | -- function is applied to 'Nothing', the output stream is closed. Note 153 | -- that 'Nothing' /must/ be provided when finishing in order to 154 | -- properly terminate video encoding. 155 | -- 156 | -- Support for source images that are of a different size to the 157 | -- output resolution is limited to non-palettized destination formats 158 | -- (i.e. those that are handled by @libswscaler@). Practically, this 159 | -- means that animated gif output is only supported if the source 160 | -- images are of the target resolution. 161 | imageWriter :: forall p. JuicyPixelFormat p 162 | => EncodingParams -> FilePath -> IO (Maybe (Image p) -> IO ()) 163 | imageWriter ep f = do 164 | videoWriter <- frameWriter ep f 165 | return $ (. fmap fromJuciy) videoWriter 166 | 167 | -- | Util function to convert a JuicyPixels image to the same structure 168 | -- used by 'frameWriter' 169 | fromJuciy :: forall p. JuicyPixelFormat p 170 | => Image p -> (AVPixelFormat, V2 CInt, V.Vector CUChar) 171 | fromJuciy img = (juicyPixelFormat ([]::[p]), V2 w h, p) 172 | where 173 | w = fromIntegral $ imageWidth img 174 | h = fromIntegral $ imageHeight img 175 | p = V.unsafeCast $ imageData img 176 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Probe.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ForeignFunctionInterface, 3 | GeneralizedNewtypeDeriving 4 | #-} 5 | 6 | module Codec.FFmpeg.Probe ( 7 | -- * Files 8 | withAvFile, nbStreams, formatName, formatMetadata, duration, 9 | 10 | -- * Streams 11 | AvStreamT, withStream, codecContext, codecName, 12 | codecMediaTypeName, streamBitrate, streamMetadata, 13 | codec, streamImageSize, 14 | 15 | -- * Dictionaries 16 | dictFoldM_ 17 | ) where 18 | 19 | import Control.Applicative ( Applicative ) 20 | import Control.Monad.Catch ( MonadMask, finally ) 21 | import Control.Monad ( liftM ) 22 | import Control.Monad.IO.Class ( MonadIO ) 23 | import Control.Monad.Reader 24 | import Control.Monad.Trans.Except 25 | import Data.Int ( Int64 ) 26 | import Foreign.C.String ( CString, peekCString, withCString ) 27 | import Foreign.C.Types ( CInt(..) ) 28 | import Foreign.Marshal.Utils ( with ) 29 | import Foreign.Ptr ( Ptr, nullPtr ) 30 | import Foreign.Storable 31 | 32 | import Codec.FFmpeg.Enums 33 | import Codec.FFmpeg.Decode 34 | import Codec.FFmpeg.Types 35 | 36 | #include 37 | 38 | ------------------------------------------------------------------------------- 39 | -- avformat - level stuff 40 | ------------------------------------------------------------------------------- 41 | 42 | newtype AvFormat m a = AvFormat { unAvFormat :: ReaderT AVFormatContext m a } 43 | deriving 44 | ( Applicative 45 | , Functor 46 | , Monad 47 | , MonadIO 48 | , MonadReader AVFormatContext 49 | , MonadTrans 50 | ) 51 | 52 | withAvFile :: (MonadMask m, MonadIO m) => String -> AvFormat m a -> m a 53 | withAvFile fn f = do 54 | ectx <- runExceptT $ openFile fn 55 | case ectx of 56 | Left e -> liftIO $ fail e 57 | Right ctx -> finally 58 | ((liftIO $ avformat_find_stream_info ctx nullPtr) >> runReaderT (unAvFormat f) ctx) 59 | (liftIO $ with ctx close_input) 60 | 61 | nbStreams :: MonadIO m => AvFormat m Int 62 | nbStreams = avToInt $ ask >>= \ctx -> 63 | liftIO $ (#peek AVFormatContext, nb_streams) (getPtr ctx) 64 | 65 | formatName :: MonadIO m => AvFormat m String 66 | formatName = ask >>= \ctx -> liftIO $ 67 | (#peek AVFormatContext, iformat) (getPtr ctx) >>= 68 | (#peek AVInputFormat, name) >>= 69 | peekCString 70 | 71 | duration :: MonadIO m => AvFormat m Int64 72 | duration = ask >>= \ctx -> liftIO $ (#peek AVFormatContext, duration) (getPtr ctx) 73 | 74 | formatMetadata :: MonadIO m => AvFormat m AVDictionary 75 | formatMetadata = ask >>= liftIO . (#peek AVFormatContext, metadata) . getPtr 76 | 77 | ------------------------------------------------------------------------------- 78 | -- stream - level stuff 79 | ------------------------------------------------------------------------------- 80 | 81 | newtype AvStreamT m a = AvStreamT { unAvStreamT :: ReaderT AVStream (m) a } 82 | deriving 83 | ( Applicative 84 | , Functor 85 | , Monad 86 | , MonadIO 87 | , MonadReader AVStream 88 | , MonadTrans 89 | ) 90 | 91 | withStream :: (MonadIO m) => Int -> AvStreamT (AvFormat m) a -> AvFormat m a 92 | withStream sid f = nbStreams >>= \ns -> if sid >= ns 93 | then error $ show sid ++ " >= " ++ show ns 94 | else do 95 | ctx <- ask 96 | streams <- liftIO $ (#peek AVFormatContext, streams) (getPtr ctx) 97 | liftIO (peekElemOff streams sid) >>= runReaderT (unAvStreamT f) 98 | 99 | codecContext :: MonadIO m => AvStreamT m (Maybe AVCodecContext) 100 | codecContext = do 101 | p <- ask >>= (liftIO . (#peek AVStream, codec) . getPtr) 102 | if (p /= nullPtr) 103 | then return $ Just $ AVCodecContext p 104 | else return Nothing 105 | 106 | codecMediaTypeName :: MonadIO m => AVCodecContext -> AvStreamT m String 107 | codecMediaTypeName cctx = liftIO $ 108 | (#peek AVCodecContext, codec_type) (getPtr cctx) >>= 109 | av_get_media_type_string >>= 110 | peekCString 111 | 112 | codec :: MonadIO m => AVCodecContext -> AvStreamT m (Maybe AVCodec) 113 | codec cctx = (liftIO . (#peek AVCodecContext, codec) . getPtr) cctx >>= 114 | \mc -> if mc == nullPtr 115 | then return Nothing 116 | else return $ Just $ AVCodec mc 117 | 118 | codecName :: MonadIO m => AVCodecContext -> AvStreamT m String 119 | codecName cctx = liftIO $ getCodecID cctx >>= avcodec_get_name >>= peekCString 120 | 121 | streamBitrate :: MonadIO m => AVCodecContext -> AvStreamT m Int 122 | streamBitrate cctx = liftIO $ getBitRate cctx >>= return . fromIntegral 123 | 124 | -- | 125 | -- Gives the (width, height) of a video stream in pixels, not accounting for the pixel aspect ratio. 126 | streamImageSize :: MonadIO m => AVCodecContext -> AvStreamT m (Int, Int) 127 | streamImageSize cctx = liftIO $ (,) 128 | <$> liftM fromIntegral (getWidth cctx) 129 | <*> liftM fromIntegral (getHeight cctx) 130 | 131 | streamMetadata :: MonadIO m => AvStreamT m AVDictionary 132 | streamMetadata = ask >>= liftIO . (#peek AVStream, metadata) . getPtr 133 | 134 | ------------------------------------------------------------------------------- 135 | -- dictionaries 136 | ------------------------------------------------------------------------------- 137 | 138 | dictFoldM_ 139 | :: MonadIO m 140 | => ((String, String) -> m ()) 141 | -> AVDictionary 142 | -> m () 143 | dictFoldM_ f d = 144 | let 145 | flags = (#const AV_DICT_IGNORE_SUFFIX + AV_DICT_DONT_STRDUP_KEY + AV_DICT_DONT_STRDUP_VAL) 146 | next ep = do 147 | e' <- liftIO $ withCString "" $ \s -> av_dict_get d s ep flags 148 | if (e' == nullPtr) 149 | then return () 150 | else do 151 | k <- liftIO $ (#peek AVDictionaryEntry, key) e' >>= peekCString 152 | v <- liftIO $ (#peek AVDictionaryEntry, value) e' >>= peekCString 153 | f (k, v) 154 | next e' 155 | in do 156 | -- e <- liftIO $ malloc >>= \m -> poke m nullPtr >> return m 157 | next nullPtr 158 | 159 | ------------------------------------------------------------------------------- 160 | -- helpers 161 | ------------------------------------------------------------------------------- 162 | 163 | avToInt :: Monad m => AvFormat m CInt -> AvFormat m Int 164 | avToInt f = f >>= return . fromIntegral 165 | 166 | ------------------------------------------------------------------------------- 167 | -- FFI imports 168 | ------------------------------------------------------------------------------- 169 | 170 | foreign import ccall "av_get_media_type_string" 171 | av_get_media_type_string :: AVMediaType -> IO CString 172 | 173 | foreign import ccall "avcodec_get_name" 174 | avcodec_get_name :: AVCodecID -> IO CString 175 | 176 | foreign import ccall "av_dict_get" 177 | av_dict_get :: AVDictionary -> CString -> Ptr () -> CInt -> IO (Ptr ()) 178 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Resampler.hs: -------------------------------------------------------------------------------- 1 | module Codec.FFmpeg.Resampler where 2 | 3 | import Codec.FFmpeg.Common 4 | import Codec.FFmpeg.Enums 5 | import Codec.FFmpeg.Types 6 | import Control.Concurrent.STM.TChan 7 | import Control.Monad (void, when) 8 | import Control.Monad.STM 9 | import Foreign.C.String 10 | import Foreign.C.Types 11 | import Foreign.Marshal.Alloc 12 | import Foreign.Ptr 13 | import Foreign.Storable 14 | 15 | foreign import ccall "swr_get_delay" 16 | swr_get_delay :: SwrContext -> CLong -> IO CLong 17 | 18 | foreign import ccall "swr_convert" 19 | swr_convert :: SwrContext -> Ptr (Ptr CUChar) -> CInt 20 | -> Ptr (Ptr CUChar) -> CInt -> IO CInt 21 | 22 | foreign import ccall "swr_get_out_samples" 23 | swr_get_out_samples :: SwrContext -> CInt -> IO CInt 24 | 25 | data AudioParams = AudioParams 26 | { apChannelLayout :: CULong 27 | , apSampleRate :: CInt 28 | , apSampleFormat :: AVSampleFormat 29 | } 30 | 31 | makeResampler :: AVCodecContext 32 | -> AudioParams 33 | -> AudioParams 34 | -> IO (AVFrame -> IO (), IO (Maybe AVFrame)) 35 | makeResampler ctx inParams outParams = do 36 | swr <- initSwrContext inParams outParams 37 | 38 | frameChan <- newTChanIO 39 | 40 | let writeFrame frame = do 41 | srcSamples <- getNumSamples frame 42 | if srcSamples == 0 43 | then return () 44 | else do 45 | srcRate <- getSampleRate frame 46 | delay <- swr_get_delay swr (fromIntegral srcRate) 47 | let dstSamples = av_rescale_rnd 48 | (delay + fromIntegral srcSamples) 49 | (fromIntegral (apSampleRate outParams)) 50 | (fromIntegral srcRate) avRoundUp 51 | srcData = castPtr (hasData frame) 52 | dstDataPtr <- malloc 53 | lineSize <- malloc 54 | dstChannelCount <- av_get_channel_layout_nb_channels 55 | (apChannelLayout outParams) 56 | _ <- runWithError "Could not alloc samples" 57 | (av_samples_alloc_array_and_samples dstDataPtr lineSize 58 | dstChannelCount (fromIntegral dstSamples) 59 | (apSampleFormat outParams) 0) 60 | dstData <- peek dstDataPtr 61 | _ <- runWithError "Error converting samples" 62 | (swr_convert swr nullPtr 0 srcData srcSamples) 63 | 64 | frameSize <- getFrameSize ctx 65 | let convertLoop = do 66 | outSamples <- swr_get_out_samples swr 0 67 | if outSamples < frameSize * dstChannelCount 68 | then return () 69 | else do 70 | aframe <- allocAudioFrame ctx 71 | _outSamples <- swr_convert swr (castPtr $ hasData aframe) 72 | frameSize nullPtr 0 73 | 74 | atomically $ writeTChan frameChan aframe 75 | convertLoop 76 | 77 | convertLoop 78 | free dstData 79 | free lineSize 80 | return () 81 | 82 | allocAudioFrame :: AVCodecContext -> IO AVFrame 83 | allocAudioFrame actx = do 84 | frame <- av_frame_alloc 85 | when (getPtr frame == nullPtr) 86 | (error "Error allocating an audio frame") 87 | 88 | setFormat frame . getSampleFormatInt =<< getSampleFormat actx 89 | setChannelLayout frame =<< getChannelLayout actx 90 | setSampleRate frame =<< getSampleRate actx 91 | fs <- (do fs <- getFrameSize actx 92 | if fs == 0 93 | then return 1000 94 | else return fs) 95 | setNumSamples frame fs 96 | 97 | _ <- runWithError "Error allocating an audio buffer" 98 | (av_frame_get_buffer frame 0) 99 | return frame 100 | 101 | readFrame = do 102 | mFrame <- atomically $ tryReadTChan frameChan 103 | case mFrame of 104 | Nothing -> return Nothing 105 | Just _ -> return mFrame 106 | 107 | return (writeFrame, readFrame) 108 | 109 | initSwrContext :: AudioParams -> AudioParams -> IO SwrContext 110 | initSwrContext inParams outParams = do 111 | swr <- swr_alloc 112 | when (getPtr swr == nullPtr) (error "Could not allocate resampler context") 113 | let set_int str i = do 114 | cStr <- newCString str 115 | _ <- av_opt_set_int (getPtr swr) cStr (fromIntegral i) 0 116 | free cStr 117 | set_sample_fmt str fmt = do 118 | cStr <- newCString str 119 | _ <- av_opt_set_sample_fmt (getPtr swr) cStr fmt 0 120 | free cStr 121 | 122 | -- set_int "in_channel_count" (aoChannelCount inParams) 123 | set_int "in_channel_layout" (apChannelLayout inParams) 124 | set_int "in_sample_rate" (apSampleRate inParams) 125 | set_sample_fmt "in_sample_fmt" (apSampleFormat inParams) 126 | -- set_int "out_channel_count" (aoChannelCount outParams) 127 | set_int "out_channel_layout" (apChannelLayout inParams) 128 | set_int "out_sample_rate" (apSampleRate outParams) 129 | set_sample_fmt "out_sample_fmt" (apSampleFormat outParams) 130 | 131 | void $ runWithError "Failed to initialize the resampling context" (swr_init swr) 132 | 133 | -- let get_int str = do 134 | -- cStr <- newCString str 135 | -- p <- malloc 136 | -- r <- av_opt_get_int (getPtr swr) cStr 0 p 137 | -- v <- peek p 138 | -- free p 139 | -- return v 140 | -- get_sample_fmt str = do 141 | -- cStr <- newCString str 142 | -- p <- malloc 143 | -- r <- av_opt_get_sample_fmt (getPtr swr) cStr 0 p 144 | -- fmt <- peek p 145 | -- free p 146 | -- return fmt 147 | 148 | return swr 149 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Scaler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, 2 | UndecidableInstances #-} 3 | module Codec.FFmpeg.Scaler where 4 | import Codec.FFmpeg.Common 5 | import Codec.FFmpeg.Enums 6 | import Codec.FFmpeg.Internal.Linear (V2(..)) 7 | import Codec.FFmpeg.Types 8 | import Codec.Picture 9 | import Data.Maybe (fromMaybe) 10 | import qualified Data.Vector.Storable as V 11 | import Foreign.C.Types 12 | import Foreign.Marshal.Array (withArray) 13 | import Foreign.Ptr (castPtr, nullPtr, Ptr) 14 | import Foreign.Storable (Storable(sizeOf)) 15 | 16 | data ImageInfo = ImageInfo { imgWidth :: CInt 17 | , imgHeight :: CInt 18 | , imgFormat :: AVPixelFormat } 19 | 20 | -- | @swsInit srcInfo dstInfo alg@ initializations an 'SwsContext' to 21 | -- scale and convert from @srcInfo@ to @dstInfo@ using the algorithm 22 | -- @alg@ when scaling. 23 | swsInit :: ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext 24 | swsInit = swsReset (SwsContext nullPtr) 25 | 26 | -- | Obtain a context for converting the source to destination 27 | -- format. If the given context is already configured for the required 28 | -- conversion, it is returned. Otherwise, the given context is freed 29 | -- and a new, configured context is returned. See 'swsInit' for a 30 | -- description of the arguments. 31 | swsReset :: SwsContext -> ImageInfo -> ImageInfo -> SwsAlgorithm 32 | -> IO SwsContext 33 | swsReset ctx src dst alg = sws_getCachedContext ctx 34 | srcW srcH srcFmt 35 | dstW dstH dstFmt 36 | alg nullPtr nullPtr nullPtr 37 | where ImageInfo srcW srcH srcFmt = src 38 | ImageInfo dstW dstH dstFmt = dst 39 | 40 | -- | A common interface required of arguments to 'swsScale' (a higher 41 | -- level wrapper for the 'sws_scale' function from @libswscale@). 42 | class SwsCompatible a where 43 | swsPlanes :: a -> (Ptr (Ptr CUChar) -> IO r) -> IO r 44 | swsStrides :: a -> (Ptr CInt -> IO r) -> IO r 45 | sliceHeight :: a -> (CInt -> IO r) -> IO r 46 | 47 | instance SwsCompatible AVFrame where 48 | swsPlanes frame k = k (castPtr $ hasData frame) 49 | swsStrides frame k = k (hasLineSize frame) 50 | sliceHeight frame k = getHeight frame >>= k 51 | 52 | instance (Pixel a, Storable (PixelBaseComponent a)) 53 | => SwsCompatible (Image a) where 54 | swsPlanes img k = V.unsafeWith (imageData img) $ \ptr -> 55 | withArray (castPtr ptr : replicate 7 nullPtr) k 56 | swsStrides img k = withArray (stride : replicate 7 0) k 57 | where sz = sizeOf (undefined::PixelBaseComponent a) * 58 | componentCount (undefined :: a) 59 | stride = fromIntegral $ imageWidth img * sz 60 | sliceHeight img k = k (fromIntegral $ imageHeight img) 61 | 62 | instance SwsCompatible (AVPixelFormat, V2 CInt, V.Vector CUChar) where 63 | swsPlanes (_,_,p) k = V.unsafeWith p $ \ptr -> 64 | withArray (castPtr ptr : replicate 7 nullPtr) k 65 | swsStrides (fmt, V2 w _, _) k = withArray (stride : replicate 7 0) k 66 | where sz = fromMaybe (error $ "Unknown pixel stride for format "++show fmt) 67 | (avPixelStride fmt) 68 | stride = w * fromIntegral sz 69 | sliceHeight (_, V2 _ h, _) k = k h 70 | 71 | -- | Supplies a continuation with all components provided by the 72 | -- 'SwsCompatible' class. 73 | withSws :: SwsCompatible a 74 | => a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r 75 | withSws img k = swsPlanes img $ \planes -> 76 | swsStrides img $ \strides -> 77 | sliceHeight img $ \height -> 78 | k planes strides height 79 | 80 | -- | @swsScale ctx src dst@ scales the entire @src@ image to @dst@ 81 | -- using the previously initialized @ctx@. 82 | swsScale :: (SwsCompatible src, SwsCompatible dst) 83 | => SwsContext -> src -> dst -> IO CInt 84 | swsScale ctx src dst = withSws src $ \srcPlanes srcStrides srcHeight -> 85 | withSws dst $ \dstPlanes dstStrides _ -> 86 | sws_scale ctx srcPlanes srcStrides 87 | 0 srcHeight 88 | dstPlanes dstStrides 89 | -------------------------------------------------------------------------------- /src/Codec/FFmpeg/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, 2 | GeneralizedNewtypeDeriving #-} 3 | module Codec.FFmpeg.Types where 4 | import Codec.FFmpeg.Enums 5 | import Control.Monad (zipWithM_,when) 6 | import Data.Maybe (fromMaybe) 7 | import Foreign.C.String (CString) 8 | import Foreign.C.Types 9 | import Foreign.Ptr 10 | import Foreign.Storable 11 | import Foreign.Marshal.Alloc (malloc) 12 | 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include "hscMacros.h" 20 | #include "nameCompat.h" 21 | 22 | class HasPtr a where 23 | getPtr :: a -> Ptr () 24 | 25 | instance HasPtr (Ptr ()) where getPtr = id 26 | 27 | newtype AVFormatContext = AVFormatContext (Ptr ()) deriving (Storable, HasPtr) 28 | #mkField NumStreams, CInt 29 | #mkField Streams, (Ptr AVStream) 30 | #mkField OutputFormat, AVOutputFormat 31 | #mkField IOContext, AVIOContext 32 | #mkField InputFormat, AVInputFormat 33 | 34 | #hasField AVFormatContext, NumStreams, nb_streams 35 | #hasField AVFormatContext, Streams, streams 36 | #hasField AVFormatContext, OutputFormat, oformat 37 | #hasField AVFormatContext, InputFormat, iformat 38 | #hasField AVFormatContext, IOContext, pb 39 | #hasField AVFormatContext, VideoCodecID, video_codec_id 40 | 41 | setFilename :: AVFormatContext -> String -> IO () 42 | setFilename ctx fn = 43 | do let ptr = getPtr ctx 44 | dst = (#ptr AVFormatContext, filename) ptr 45 | bytes = map (fromIntegral . fromEnum) fn 46 | zipWithM_ (pokeElemOff dst) bytes [(0 :: CInt) ..] 47 | 48 | 49 | foreign import ccall "av_input_video_device_next" 50 | av_input_video_device_next :: AVInputFormat -> IO AVInputFormat 51 | 52 | setCamera :: AVFormatContext -> IO () 53 | setCamera ctx = do 54 | ipt <- getCameraAVInputFormat (AVInputFormat nullPtr) 55 | setInputFormat ctx ipt 56 | where 57 | -- Currently straight-line, but we can filter each 'nxt' based on 58 | -- predicates, such as device ('avfoundtion', 'v4l2' etc) in the 59 | -- future, if needed. 60 | getCameraAVInputFormat :: AVInputFormat -> IO AVInputFormat 61 | getCameraAVInputFormat p = do 62 | nxt <- av_input_video_device_next p 63 | when (nullPtr == getPtr nxt) (error "No video input device found.") 64 | return nxt 65 | 66 | foreign import ccall "avformat_alloc_context" 67 | avformat_alloc_context :: IO (Ptr ()) 68 | 69 | mallocAVFormatContext :: IO AVFormatContext 70 | mallocAVFormatContext = AVFormatContext <$> avformat_alloc_context 71 | 72 | newtype AVCodecContext = AVCodecContext (Ptr ()) deriving (Storable, HasPtr) 73 | 74 | foreign import ccall "avcodec_alloc_context3" 75 | avcodec_alloc_context3 :: AVCodec -> IO AVCodecContext 76 | 77 | #mkField BitRate, CInt 78 | 79 | #mkField SampleFormat, AVSampleFormat 80 | #mkField Width, CInt 81 | #mkField Height, CInt 82 | #mkField TimeBase, AVRational 83 | #mkField GopSize, CInt 84 | #mkField PixelFormat, AVPixelFormat 85 | #mkField CodecFlags, CodecFlag 86 | #mkField CodecID, AVCodecID 87 | #mkField PrivData, (Ptr ()) 88 | #mkField TicksPerFrame, CInt 89 | #mkField RawAspectRatio, AVRational 90 | #mkField SampleRate, CInt 91 | #mkField ChannelLayout, CULong 92 | #mkField Channels, CInt 93 | #mkField FrameSize, CInt 94 | #mkField FrameRate, AVRational 95 | 96 | #hasField AVCodecContext, BitRate, bit_rate 97 | #hasField AVCodecContext, Width, width 98 | #hasField AVCodecContext, Height, height 99 | #hasField AVCodecContext, TimeBase, time_base 100 | #hasField AVCodecContext, GopSize, gop_size 101 | #hasField AVCodecContext, PixelFormat, pix_fmt 102 | #hasField AVCodecContext, CodecFlags, flags 103 | #hasField AVCodecContext, CodecID, codec_id 104 | #hasField AVCodecContext, PrivData, priv_data 105 | #hasField AVCodecContext, TicksPerFrame, ticks_per_frame 106 | #hasField AVCodecContext, RawAspectRatio, sample_aspect_ratio 107 | #hasField AVCodecContext, SampleRate, sample_rate 108 | #hasField AVCodecContext, ChannelLayout, channel_layout 109 | #hasField AVCodecContext, Channels, channels 110 | #hasField AVCodecContext, SampleFormat, sample_fmt 111 | #hasField AVCodecContext, FrameSize, frame_size 112 | #hasField AVCodecContext, FrameRate, framerate 113 | 114 | getFps :: (HasTimeBase a, HasTicksPerFrame a) => a -> IO CDouble 115 | getFps x = do 116 | timeBase <- getTimeBase x 117 | ticksPerFrame <- getTicksPerFrame x 118 | pure (1.0 / av_q2d timeBase / fromIntegral ticksPerFrame) 119 | 120 | getAspectRatio :: HasRawAspectRatio a => a -> IO (Maybe AVRational) 121 | getAspectRatio = fmap nonZeroAVRational . getRawAspectRatio 122 | 123 | -- | When unspecified, the most likely pixel shape is a square 124 | guessAspectRatio :: HasRawAspectRatio a => a -> IO AVRational 125 | guessAspectRatio = fmap (fromMaybe (AVRational 1 1)) . getAspectRatio 126 | 127 | setAspectRatio :: HasRawAspectRatio a => a -> Maybe AVRational -> IO () 128 | setAspectRatio x Nothing = setRawAspectRatio x (AVRational 0 1) 129 | setAspectRatio x (Just ratio) = setRawAspectRatio x ratio 130 | 131 | newtype AVCodecParameters = AVCodecParameters (Ptr ()) deriving (Storable, HasPtr) 132 | 133 | foreign import ccall "avcodec_parameters_from_context" 134 | avcodec_parameters_from_context :: AVCodecParameters 135 | -> AVCodecContext 136 | -> IO CInt 137 | 138 | newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr) 139 | #mkField Id, CInt 140 | #mkField CodecContext, AVCodecContext 141 | #mkField StreamIndex, CInt 142 | #mkField CodecParams, AVCodecParameters 143 | 144 | #hasField AVStream, Id, id 145 | #hasField AVStream, TimeBase, time_base 146 | #hasField AVStream, CodecContext, codec 147 | #hasField AVStream, StreamIndex, index 148 | #hasField AVStream, CodecParams, codecpar 149 | 150 | newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) 151 | #mkField LongName, CString 152 | #mkField Name, CString 153 | #mkField PixelFormats, (Ptr AVPixelFormat) 154 | #mkField SampleFormats, (Ptr AVSampleFormat) 155 | #mkField ChannelLayouts, (Ptr CULong) 156 | #mkField SupportedSampleRates, (Ptr CInt) 157 | #mkField Capabilities, CInt 158 | 159 | #hasField AVCodec, LongName, long_name 160 | #hasField AVCodec, Name, name 161 | #hasField AVCodec, CodecID, id 162 | #hasField AVCodec, PixelFormats, pix_fmts 163 | #hasField AVCodec, SampleFormats, sample_fmts 164 | #hasField AVCodec, ChannelLayouts, channel_layouts 165 | #hasField AVCodec, SupportedSampleRates, supported_samplerates 166 | #hasField AVCodec, Capabilities, capabilities 167 | 168 | newtype AVDictionary = AVDictionary (Ptr ()) deriving (Storable, HasPtr) 169 | newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr) 170 | #mkField Pts, CLong 171 | #mkField PktPts, CLong 172 | #mkField LineSize, CInt 173 | #mkField Data, (Ptr (Ptr ())) 174 | #mkField ExtendedData, (Ptr (Ptr ())) 175 | #mkField NumSamples, CInt 176 | #mkField Format, CInt 177 | 178 | #hasField AVFrame, PixelFormat, format 179 | #hasField AVFrame, SampleFormat, format 180 | #hasField AVFrame, Width, width 181 | #hasField AVFrame, Height, height 182 | #hasField AVFrame, LineSize, linesize 183 | #hasField AVFrame, Pts, pts 184 | #hasField AVFrame, PktPts, pkt_pts 185 | #hasField AVFrame, Data, data 186 | #hasField AVFrame, ExtendedData, extended_data 187 | #hasField AVFrame, NumSamples, nb_samples 188 | #hasField AVFrame, Format, format 189 | #hasField AVFrame, Channels, channels 190 | #hasField AVFrame, ChannelLayout, channel_layout 191 | #hasField AVFrame, SampleRate, sample_rate 192 | 193 | newtype AVPicture = AVPicture (Ptr ()) deriving (Storable, HasPtr) 194 | #hasField AVPicture, Data, data 195 | 196 | newtype SwsContext = SwsContext (Ptr ()) deriving (Storable, HasPtr) 197 | newtype AVOutputFormat = AVOutputFormat (Ptr ()) deriving (Storable, HasPtr) 198 | #mkField FormatFlags, FormatFlag 199 | #mkField VideoCodecID, AVCodecID 200 | #mkField AudioCodecID, AVCodecID 201 | #hasField AVOutputFormat, FormatFlags, flags 202 | #hasField AVOutputFormat, VideoCodecID, video_codec 203 | #hasField AVOutputFormat, AudioCodecID, audio_codec 204 | 205 | newtype AVInputFormat = AVInputFormat (Ptr ()) deriving (Storable, HasPtr) 206 | newtype AVClass = AVClass (Ptr ()) deriving (Storable, HasPtr) 207 | #mkField AVClass, AVClass 208 | #hasField AVInputFormat, AVClass, priv_class 209 | 210 | #if LIBAVUTIL_VERSION_MAJOR > 52 211 | getAVCategory :: AVInputFormat -> IO Category 212 | getAVCategory aif = 213 | do c <- getAVClass aif 214 | if nullPtr == getPtr c 215 | then return (Category (-1)) 216 | else Category <$> peek ((#ptr AVClass, category) $ castPtr $ getPtr c) 217 | 218 | newtype Category = Category CInt deriving (Eq,Ord,Show,Read,Enum) 219 | #enum Category, Category, AV_CLASS_CATEGORY_NA, AV_CLASS_CATEGORY_INPUT,\ 220 | AV_CLASS_CATEGORY_OUTPUT, AV_CLASS_CATEGORY_MUXER, AV_CLASS_CATEGORY_DEMUXER,\ 221 | AV_CLASS_CATEGORY_ENCODER, AV_CLASS_CATEGORY_DECODER, AV_CLASS_CATEGORY_FILTER,\ 222 | AV_CLASS_CATEGORY_BITSTREAM_FILTER, AV_CLASS_CATEGORY_SWSCALER, AV_CLASS_CATEGORY_SWRESAMPLER,\ 223 | AV_CLASS_CATEGORY_DEVICE_VIDEO_OUTPUT, AV_CLASS_CATEGORY_DEVICE_VIDEO_INPUT, AV_CLASS_CATEGORY_DEVICE_AUDIO_OUTPUT,\ 224 | AV_CLASS_CATEGORY_DEVICE_AUDIO_INPUT, AV_CLASS_CATEGORY_DEVICE_OUTPUT, AV_CLASS_CATEGORY_DEVICE_INPUT,\ 225 | AV_CLASS_CATEGORY_NB 226 | #endif 227 | 228 | newtype AVIOContext = AVIOContext (Ptr ()) deriving (Storable, HasPtr) 229 | 230 | newtype AVPacket = AVPacket (Ptr ()) deriving (Storable, HasPtr) 231 | #mkField PktData, (Ptr ()) 232 | #mkField Size, CInt 233 | #mkField PacketFlags, PacketFlag 234 | #mkField Dts, CLong 235 | #mkField Duration, CULong 236 | 237 | #hasField AVPacket, PktData, data 238 | #hasField AVPacket, Size, size 239 | #hasField AVPacket, PacketFlags, flags 240 | #hasField AVPacket, StreamIndex, stream_index 241 | #hasField AVPacket, Pts, pts 242 | #hasField AVPacket, Dts, dts 243 | #hasField AVPacket, Duration, duration 244 | 245 | -- | @sizeof@ the 'AVPacket' structure in bytes. 246 | packetSize :: Int 247 | packetSize = #size AVPacket 248 | 249 | pictureSize :: Int 250 | pictureSize = #size AVPicture 251 | 252 | newtype SwrContext = SwrContext (Ptr ()) deriving (Storable, HasPtr) 253 | 254 | newtype AVAudioFifo = AVAudioFifo (Ptr ()) deriving (Storable, HasPtr) 255 | 256 | foreign import ccall "av_samples_alloc_array_and_samples" 257 | av_samples_alloc_array_and_samples :: Ptr (Ptr (Ptr CUChar)) 258 | -> Ptr CInt 259 | -> CInt 260 | -> CInt 261 | -> AVSampleFormat 262 | -> CInt 263 | -> IO CInt 264 | 265 | foreign import ccall "av_audio_fifo_free" 266 | av_audio_fifo_free :: AVAudioFifo -> IO () 267 | 268 | foreign import ccall "av_audio_fifo_alloc" 269 | av_audio_fifo_alloc :: AVSampleFormat -> CInt -> CInt -> IO AVAudioFifo 270 | 271 | foreign import ccall "av_audio_fifo_realloc" 272 | av_audio_fifo_realloc :: AVAudioFifo -> CInt -> IO CInt 273 | 274 | foreign import ccall "av_audio_fifo_write" 275 | av_audio_fifo_write :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt 276 | 277 | foreign import ccall "av_audio_fifo_peek" 278 | av_audio_fifo_peek :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt 279 | 280 | foreign import ccall "av_audio_fifo_peek_at" 281 | av_audio_fifo_peek_at :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> CInt -> IO CInt 282 | 283 | foreign import ccall "av_audio_fifo_read" 284 | av_audio_fifo_read :: AVAudioFifo -> Ptr (Ptr ()) -> CInt -> IO CInt 285 | 286 | foreign import ccall "av_audio_fifo_drain" 287 | av_audio_fifo_drain :: AVAudioFifo -> CInt -> IO CInt 288 | 289 | foreign import ccall "av_audio_fifo_reset" 290 | av_audio_fifo_reset :: AVAudioFifo -> IO () 291 | 292 | foreign import ccall "av_audio_fifo_size" 293 | av_audio_fifo_size :: AVAudioFifo -> IO CInt 294 | 295 | foreign import ccall "av_audio_fifo_space" 296 | av_audio_fifo_space :: AVAudioFifo -> IO CInt 297 | 298 | -- * Types with Haskell equivalents 299 | 300 | data AVRational = AVRational { numerator :: CInt 301 | , denomenator :: CInt } deriving Show 302 | 303 | -- | FFmpeg often uses 0 to mean "unknown"; use 'Nothing' instead.VRational 304 | nonZeroAVRational :: AVRational -> Maybe AVRational 305 | nonZeroAVRational (AVRational 0 _) = Nothing 306 | nonZeroAVRational ratio = Just ratio 307 | 308 | instance Storable AVRational where 309 | sizeOf _ = #size AVRational 310 | alignment _ = #size AVRational 311 | peek ptr = AVRational <$> (#peek AVRational, num) ptr 312 | <*> (#peek AVRational, den) ptr 313 | poke ptr (AVRational n d) = do (#poke AVRational, num) ptr n 314 | (#poke AVRational, den) ptr d 315 | 316 | foreign import ccall "av_rescale_rnd" 317 | av_rescale_rnd :: CLong -> CLong -> CLong -> AVRoundMode -> CLong 318 | 319 | -- | Convert an 'AVRational' to a 'Double' 320 | av_q2d :: AVRational -> CDouble 321 | av_q2d r = fromIntegral (numerator r) / fromIntegral (denomenator r) 322 | 323 | -- | Rescale an integer from one time base to another. 324 | av_rescale_q :: CLong -> AVRational -> AVRational -> CLong 325 | av_rescale_q a bq cq = av_rescale_rnd a b c avRoundNearInf 326 | where b = fromIntegral (numerator bq) * fromIntegral (denomenator cq) 327 | c = fromIntegral (numerator cq) * fromIntegral (denomenator bq) 328 | 329 | foreign import ccall "av_packet_rescale_ts" 330 | av_packet_rescale_ts :: AVPacket -> Ptr AVRational -> Ptr AVRational -> IO () 331 | 332 | foreign import ccall "av_packet_unref" 333 | av_packet_unref :: AVPacket -> IO () 334 | 335 | packet_rescale_ts :: AVPacket -> AVRational -> AVRational -> IO () 336 | packet_rescale_ts packet rat1 rat2 = do 337 | ptr1 <- malloc 338 | ptr2 <- malloc 339 | poke ptr1 rat1 340 | poke ptr2 rat2 341 | av_packet_rescale_ts packet ptr1 ptr2 342 | 343 | 344 | #if LIBAVFORMAT_VERSION_MAJOR < 57 345 | data AVFrac = AVFrac { fracVal :: CLong 346 | , fracNum :: CLong 347 | , fracDen :: CLong } deriving Show 348 | 349 | instance Storable AVFrac where 350 | sizeOf _ = #size AVFrac 351 | alignment _ = #size AVFrac 352 | peek ptr = AVFrac <$> (#peek AVFrac, val) ptr 353 | <*> (#peek AVFrac, num) ptr 354 | <*> (#peek AVFrac, den) ptr 355 | poke ptr (AVFrac v n d) = do (#poke AVFrac, val) ptr v 356 | (#poke AVFrac, num) ptr n 357 | (#poke AVFrac, den) ptr d 358 | #endif 359 | 360 | -- | The input source can be a file or a camera. When using 'Camera', 361 | -- frequently in the form @Camera "0:0" defaultCameraConfig@, the first input video device 362 | -- enumerated by libavdevice is selected. 363 | data InputSource = File FilePath | Camera String CameraConfig 364 | deriving (Eq, Ord, Show, Read) 365 | 366 | data CameraConfig = 367 | CameraConfig { framerate :: Maybe Int 368 | , resolution :: Maybe (Int,Int) 369 | , format :: Maybe String 370 | -- ^ Short name for a video format (e.g. @"v4l2"@) 371 | } 372 | deriving (Eq,Ord,Show,Read) 373 | 374 | defaultCameraConfig :: CameraConfig 375 | defaultCameraConfig = CameraConfig (Just 30) Nothing Nothing 376 | -------------------------------------------------------------------------------- /src/hscMacros.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* 4 | Creates a class for a field with a particular Haskell type. 5 | Example: #mkField Width, CInt 6 | Generates: 7 | class HasWidth t where 8 | getWidth :: t -> IO CInt 9 | setWidth :: t -> CInt -> IO () 10 | hasWidth :: t -> Ptr CInt 11 | */ 12 | 13 | #define hsc_mkField(name, hType) \ 14 | printf("class Has%s t where\n", #name);\ 15 | printf(" get%s :: t -> IO %s\n", #name, #hType);\ 16 | printf(" set%s :: t -> %s -> IO ()\n", #name, #hType);\ 17 | printf(" has%s :: t -> Ptr %s\n", #name, #hType); 18 | 19 | /* 20 | Creates an instance of settable field class. The assumption is that 21 | the first argument, the type name, is the name of bot the C and 22 | Haskell types involved. This makes use of the HasPtr class whose 23 | single method, getPtr, with type "a -> Ptr ()", unwraps a raw Ptr from 24 | a value (typically a newtype around a Ptr). 25 | 26 | Example: #hasField AVCodecContext, BitRate, bit_rate 27 | Generates: 28 | instance HasBitRate AVCodecContext where 29 | getBitRate = (#peek AVCodecContext, bit_rate) . getPtr 30 | setBitRate = (#poke AVCodecContext, bit_rate) . getPtr 31 | hasBitRate = (#ptr AVCodecContext, bit_rate) . getPtr 32 | */ 33 | 34 | #define hsc_hasField(type, hName, cName) \ 35 | printf("instance Has%s %s where\n", #hName, #type);\ 36 | printf(" get%s = ", #hName);\ 37 | hsc_peek(type, cName)\ 38 | printf(" . getPtr\n");\ 39 | printf(" set%s = ", #hName);\ 40 | hsc_poke(type, cName)\ 41 | printf(" . getPtr\n");\ 42 | printf(" has%s = ", #hName);\ 43 | hsc_ptr(type, cName)\ 44 | printf(" . getPtr\n"); 45 | 46 | -------------------------------------------------------------------------------- /src/nameCompat.h: -------------------------------------------------------------------------------- 1 | /* Older versions of libav (and perhaps ffmpeg) used a different 2 | naming scheme for constants. Since distributions like Ubuntu 12.04 3 | are locked down with these old versions, we hack in support for the 4 | newer constant names. */ 5 | 6 | #if LIBAVUTIL_VERSION_MAJOR < 53 7 | #define AV_PIX_FMT_NONE PIX_FMT_NONE 8 | #define AV_PIX_FMT_RGB24 PIX_FMT_RGB24 9 | #define AV_PIX_FMT_RGBA PIX_FMT_RGBA 10 | #define AV_PIX_FMT_BGRA PIX_FMT_BGRA 11 | #define AV_PIX_FMT_Y400A PIX_FMT_Y400A 12 | #define AV_PIX_FMT_RGB8 -1 13 | #define AV_PIX_FMT_BGR8 -1 14 | #define AV_PIX_FMT_RGB4_BYTE -1 15 | #define AV_PIX_FMT_BGR4_BYTE -1 16 | #define AV_PIX_FMT_GRAY8 PIX_FMT_GRAY8 17 | #define AV_PIX_FMT_GRAY8A -1 18 | #define AV_PIX_FMT_YUV420P PIX_FMT_YUV420P 19 | #define AV_PIX_FMT_YUV420P12 -1 20 | #define AV_PIX_FMT_YUV422P12 -1 21 | #define AV_PIX_FMT_YUV444P12 -1 22 | #define AV_PIX_FMT_YUV420P14 -1 23 | #define AV_PIX_FMT_YUV422P14 -1 24 | #define AV_PIX_FMT_YUV444P14 -1 25 | #define AV_PIX_FMT_RGBA64 -1 26 | #define AV_PIX_FMT_BGRA64 -1 27 | #define AV_PIX_FMT_PAL8 PIX_FMT_PAL8 28 | 29 | #define AV_CODEC_ID_H264 CODEC_ID_H264 30 | #define AV_CODEC_ID_THEORA CODEC_ID_THEORA 31 | #define AV_CODEC_ID_MPEG4 CODEC_ID_MPEG4 32 | #define AV_CODEC_ID_MPEG2VIDEO CODEC_ID_MPEG2VIDEO 33 | #define AV_CODEC_ID_GIF CODEC_ID_GIF 34 | #define AV_CODEC_ID_AAC CODEC_ID_AAC 35 | #define AV_CODEC_ID_MP3 CODEC_ID_MP3 36 | #define AV_CODEC_ID_DTS CODEC_ID_DTS 37 | #define AV_CODEC_ID_HEVC -1 38 | #define AV_CODEC_ID_VC1 -1 39 | #define AV_CODEC_ID_RAWVIDEO CODEC_ID_RAWVIDEO 40 | 41 | #define FF_PROFILE_MPEG2_AAC_LOW -1 42 | #define FF_PROFILE_MPEG2_AAC_HE -1 43 | 44 | #define AVIO_FLAG_DIRECT -1 45 | 46 | #define AV_ROUND_PASS_MINMAX -1 47 | 48 | #define CODEC_FLAG_UNALIGNED -1 49 | #define CODEC_FLAG_OUTPUT_CORRUPT -1 50 | 51 | #define AV_LOG_TRACE 56 52 | #define AV_LOG_MAX_OFFSET (AV_LOG_TRACE - AV_LOG_QUIET) 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.21 2 | 3 | packages: 4 | - '.' 5 | 6 | # Dependency packages to be pulled from upstream that are not in the resolver 7 | # (e.g., acme-missiles-0.3) 8 | extra-deps: 9 | - Rasterific-0.6.1.1 10 | - FontyFruity-0.5.3.2 11 | - sdl2-2.1.3.1 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: 15 | ffmpeg-light: 16 | BuildDemo: true 17 | BuildRasterDemo: true 18 | BuildVPlayDemo: true 19 | BuildTranscodeDemo: true 20 | BuildAudioExtractDemo: true 21 | BuildAudioSinDemo: true 22 | 23 | # Extra package databases containing global packages 24 | extra-package-dbs: [] 25 | 26 | # Control whether we use the GHC we find on the path 27 | nix: 28 | enable: false 29 | packages: [ ffmpeg-full, pkgconfig, zlib, SDL2 ] 30 | pure: false 31 | 32 | # Extra directories used by stack for building 33 | # extra-include-dirs: [/path/to/dir] 34 | # extra-lib-dirs: [/path/to/dir] 35 | 36 | # nix-store -r $(nix-instantiate '' -A ffmpeg-full) 37 | # extra-include-dirs: [/nix/store/nq5n4053yhkxwwlirjm4k8zh1r1hzc16-ffmpeg-full-3.0/include] 38 | # extra-lib-dirs: [/nix/store/nq5n4053yhkxwwlirjm4k8zh1r1hzc16-ffmpeg-full-3.0/lib] 39 | # 40 | # Allow a newer minor version of GHC than the snapshot specifies 41 | # compiler-check: newer-minor 42 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Rasterific-0.6.1.1@sha256:02890bd3903e37aebfe8c89909ea108a9fc253053f5368ce0e3ff4544fbaa7d6,5324 9 | pantry-tree: 10 | size: 6278 11 | sha256: bb38f7aafda4c993e43e8aca3feca1083e5a8c2cec4be3756206b87251a040c7 12 | original: 13 | hackage: Rasterific-0.6.1.1 14 | - completed: 15 | hackage: FontyFruity-0.5.3.2@sha256:cd43670271c4b96d7a44d199ba52ed087281db52427332077bad187ad89d8bd9,2112 16 | pantry-tree: 17 | size: 1312 18 | sha256: 686e11a72cf6e6276744d11e838ae880e52f4fbf29dc1c909901312e808d5db5 19 | original: 20 | hackage: FontyFruity-0.5.3.2 21 | - completed: 22 | hackage: sdl2-2.1.3.1@sha256:13f4bbee291193e48d33888ee6fba3696fe04b464157fca3a9e7fc443bba4dc1,9466 23 | pantry-tree: 24 | size: 6182 25 | sha256: b6090e850aa6f1f63fe1af36b79d1cd01507be3bf19fe17e251f78656eb2267b 26 | original: 27 | hackage: sdl2-2.1.3.1 28 | snapshots: 29 | - completed: 30 | size: 537868 31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/21.yaml 32 | sha256: 0a3be91c2bce851de4755003cfb1d85d62b6f90276231fcc305729c0c5c864a9 33 | original: lts-9.21 34 | -------------------------------------------------------------------------------- /vagrant-bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Install FFmpeg dependencies 4 | apt-get update 5 | apt-get -y install autoconf automake build-essential libass-dev \ 6 | libfreetype6-dev libgpac-dev libtheora-dev libtool libvorbis-dev \ 7 | pkg-config texi2html zlib1g-dev yasm unzip libmp3lame-dev 8 | 9 | # Install support for add-apt-repository for working with PPAs 10 | apt-get install -y python-software-properties software-properties-common 11 | 12 | # Get GHC and cabal-install from Herbert's PPA 13 | add-apt-repository ppa:hvr/ghc 14 | sed 's/ trusty / precise /' /etc/apt/sources.list.d/hvr-ghc-trusty.list > /etc/apt/sources.list.d/hvr-ghc-precise.list 15 | apt-get update 16 | apt-get install -y ghc-7.8.3 17 | apt-get install -y cabal-install-1.20 18 | 19 | # cabal-install bash completion 20 | wget https://raw.githubusercontent.com/haskell/cabal/master/cabal-install/bash-completion/cabal -O /etc/bash_completion.d/cabal 21 | 22 | # Setup PATH, run cabal update, and configure SSH 23 | su vagrant <> ~/.bashrc 25 | export PATH=/home/vagrant/.cabal/bin:/opt/ghc/7.8.3/bin:/opt/cabal/1.20/bin:$PATH 26 | /opt/cabal/1.20/bin/cabal update 27 | # /opt/cabal/1.20/bin/cabal install cabal-install 28 | EOF 29 | --------------------------------------------------------------------------------