packages feed

flac (empty) → 0.1.0

raw patch · 46 files changed

+5319/−0 lines, 46 filesdep +basedep +bytestringdep +containerssetup-changedbinary-added

Dependencies added: base, bytestring, containers, data-default-class, directory, exceptions, filepath, flac, hspec, mtl, semigroups, temporary, text, transformers, vector, wave

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## FLAC 0.1.0++* Initial release.
+ Codec/Audio/FLAC/Metadata.hs view
@@ -0,0 +1,971 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- The module provides a complete high-level Haskell API to manipulate FLAC+-- metadata.+--+-- === How to use this module+--+-- Just like other modules of this library, the API is file-centered — no+-- streaming support is available at this time (in libFLAC as well).+-- Retrieving and editing metadata information is very easy, you only need+-- three functions: 'runFlacMeta', 'retrieve', and @('=->')@.+--+-- Here is how to get sample rate and artist name and print them:+--+-- > import Codec.Audio.FLAC.Metadata+-- > import Control.Monad.IO.Class (MonadIO (..))+-- > import Data.Default.Class+-- >+-- > main :: IO ()+-- > main = runFlacMeta def "/path/to/my/file.flac" $ do+-- >   retrieve SampleRate             >>= liftIO . print+-- >   retrieve (VorbisComment Artist) >>= liftIO . print+--+-- Normally you would just return them packed in a tuple from the monad, of+-- course. We print the values just for demonstration.+--+-- The next example shows how to set a couple of tags:+--+-- > import Codec.Audio.FLAC.Metadata+-- > import Data.Default.Class+-- >+-- > main :: IO ()+-- > main = runFlacMeta def "/path/to/my/file.flac" $ do+-- >   VorbisComment Artist =-> Just "Alexander Scriabin"+-- >   VorbisComment Title  =-> Just "Sonata №9 “Black Mass”, Op. 68"+-- >   VorbisComment Date   =-> Nothing+--+-- Here we write two tags using the @('=->')@ operator and delete the+-- @'VorbisComment' 'Date'@ metadata attribute by setting it to 'Nothing'.+-- Note that not all attributes are writable, so we cannot set things like+-- 'SampleRate'. In fact, the type system mechanics used in the library+-- prevent this.+--+-- === Low-level details+--+-- The implementation uses the reference implementation of FLAC — libFLAC (C+-- library) under the hood. This means you'll need at least version 1.3.0 of+-- libFLAC (released 26 May 2013) installed for the binding to work.+--+-- This module in particular uses level 2 metadata interface and it's not+-- possible to choose other interface (such as level 0 and 1). This should+-- not be of any concern to end-user, however, as level 2 supports more+-- functionality than the other levels.++{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstrainedClassMethods    #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeFamilies               #-}++#if MIN_VERSION_base(4,9,0)+{-# LANGUAGE UndecidableInstances       #-}+#else+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+#endif++module Codec.Audio.FLAC.Metadata+  ( -- * Metadata manipulation API+    FlacMeta+  , MetaSettings (..)+  , MetaException (..)+  , MetaChainStatus (..)+  , runFlacMeta+    -- * Meta values+  , MetaValue (..)+  , MinBlockSize (..)+  , MaxBlockSize (..)+  , MinFrameSize (..)+  , MaxFrameSize (..)+  , SampleRate (..)+  , Channels (..)+  , ChannelMask (..)+  , BitsPerSample (..)+  , TotalSamples (..)+  , FileSize (..)+  , BitRate (..)+  , MD5Sum (..)+  , Duration (..)+  , Application (..)+  , ApplicationId+  , mkApplicationId+  , unApplicationId+  , SeekTable (..)+  , SeekPoint (..)+  , VorbisVendor (..)+  , VorbisComment (..)+  , VorbisField (..)+  , CueSheet (..)+  , Picture (..)+  , PictureType (..)+  , PictureData (..)+    -- * Extra functionality+  , wipeVorbisComment+  , wipeApplications+  , wipeSeekTable+  , wipeCueSheets+  , wipePictures+    -- * Debugging and testing+  , MetadataType (..)+  , getMetaChain+  , isMetaChainModified )+where++import Codec.Audio.FLAC.Metadata.Internal.Level2Interface+import Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers+import Codec.Audio.FLAC.Metadata.Internal.Object+import Codec.Audio.FLAC.Metadata.Internal.Types+import Codec.Audio.Wave+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.Reader+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.Char (toUpper)+import Data.Default.Class+import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromJust, listToMaybe)+import Data.Set (Set)+import Data.Text (Text)+import Data.Vector (Vector)+import Foreign hiding (void)+import Numeric.Natural+import Prelude hiding (iterate)+import System.IO+import qualified Data.ByteString.Char8 as B8+import qualified Data.List.NonEmpty    as NE+import qualified Data.Set              as E+import qualified Data.Vector           as V++#if MIN_VERSION_base(4,9,0)+import Data.Kind (Constraint)+import GHC.TypeLits+#else+import GHC.Exts (Constraint)+#endif++----------------------------------------------------------------------------+-- Metadata manipulation API++-- | An opaque monad for reading and writing of FLAC metadata. The monad is+-- the home for 'retrieve' and @('=->')@ functions and can be run with+-- 'runFlacMeta'.++newtype FlacMeta a = FlacMeta { unFlacMeta :: Inner a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadIO+           , MonadThrow+           , MonadCatch+           , MonadMask )++-- | Non-public shortcut for inner monad stack of 'FlacMeta'.++type Inner a = ReaderT Context IO a++-- | Context that 'Inner' passes around.++data Context = Context+  { metaChain    :: MetaChain     -- ^ Metadata chain+  , metaModified :: IORef Bool    -- ^ “Modified” flag+  , metaFileSize :: Natural       -- ^ Size of target file+  }++-- | Settings that control how metadata is written in FLAC file.++data MetaSettings = MetaSettings+  { metaAutoVacuum :: !Bool+    -- ^ Whether to traverse all metadata blocks just before padding sorting+    -- (if enabled, see 'metaSortPadding') and writing data to file,+    -- deleting all metadata blocks that appear to be empty, e.g. vorbis+    -- comment block without any comments (tags) in it. Default value:+    -- 'True'.+  , metaSortPadding :: !Bool+    -- ^ Whether to attempt to sort and consolidate all padding at the end+    -- of metadata section. The main purpose of this is that the padding can+    -- be truncated if necessary to get more space so we can overwrite+    -- metadata blocks in place instead of overwriting the entire FLAC file.+    -- Default value: 'True'.+  , metaUsePadding :: !Bool+    -- ^ This setting enables truncation of last padding metadata block if+    -- it allows to overwrite metadata in place instead of overwriting the+    -- entire file. Default value: 'True'.+  , metaPreserveFileStats :: !Bool+    -- ^ If 'True', the owner and modification time will be preserved even+    -- if new FLAC file is written (this is for the cases when we need to+    -- write entire FLAC file and thus a copy of the file is written).+    -- Default value: 'True'.+  } deriving (Show, Read, Eq, Ord)++instance Default MetaSettings where+  def = MetaSettings+    { metaAutoVacuum        = True+    , metaSortPadding       = True+    , metaUsePadding        = True+    , metaPreserveFileStats = True }++-- | Run an action that manipulates FLAC metadata. 'MetaSettings' control+-- subtle and rather low-level details of metadata editing, just pass 'def'+-- unless you know what you are doing. 'FilePath' specifies location of FLAC+-- file to read\/edit in the file system. 'FlacMeta' is a monadic action+-- that describes what to do with metadata. Compose it from 'retrieve' and+-- @('=->')@.+--+-- The action will throw 'Data.Text.Encoding.Error.UnicodeException' if text+-- data like Vorbis Comment entries cannot be read as UTF-8-encoded value.+--+-- If a problem occurs, 'MetaException' is thrown with attached+-- 'MetaChainStatus' that should help investigating what went wrong.++runFlacMeta :: MonadIO m+  => MetaSettings      -- ^ Settings to use+  -> FilePath          -- ^ File to operate on+  -> FlacMeta a        -- ^ Actions to perform+  -> m a               -- ^ The result+runFlacMeta MetaSettings {..} path m = liftIO . withChain $ \metaChain -> do+  metaModified <- newIORef False+  metaFileSize <- fromIntegral <$> withFile path ReadMode hFileSize+  flip runReaderT Context {..} $ do+    liftBool (chainRead metaChain path)+    result   <- unFlacMeta m+    modified <- liftIO (readIORef metaModified)+    when modified $ do+      when metaAutoVacuum applyVacuum+      when metaSortPadding $+        liftIO (chainSortPadding metaChain)+      liftBool+        (chainWrite metaChain metaUsePadding metaPreserveFileStats)+    return result++----------------------------------------------------------------------------+-- Meta values++-- | A class for types that specify which metadata attributes to+-- read\/write. It's not expected that users of the library will define new+-- metadata attributes other than via combination of existing ones, which is+-- also useful. For example, 'Duration' and 'BitRate' are not read from FLAC+-- file metadata directly, but defined in terms of other attributes.++class MetaValue a where++  -- | Type of data that corresponds to this metadata value. For example+  -- 'SampleRate' is represented by 'Word32' value in this library, and so+  -- @'MetaType' 'SampleRate' = 'Word32'@.++  type MetaType a :: *++  -- | Associated type of kind 'Constraint' that controls whether particular+  -- piece of metadata is writable or not.++  type MetaWritable a :: Constraint++  -- | Given value that determines what to read, read it and return. Some+  -- metadata may be missing, in that case the function typically returns a+  -- value wrapped in 'Maybe'.++  retrieve :: a -> FlacMeta (MetaType a)++  -- | Given value that determines what to write and a value to write,+  -- add\/replace a piece of metadata information. This is how you edit+  -- metadata. To delete something, set it to 'Nothing' (well, it should be+  -- something that /can be missing/, for example you cannot delete+  -- 'SampleRate' attribute). If 'MetaWritable' is defined, this method must+  -- be defined as well.++  (=->) :: MetaWritable a => a -> MetaType a -> FlacMeta ()+  _ =-> _ = error "Codec.Audio.FLAC.Metadata.(=->) is not defined"++infix 1 =->++#if MIN_VERSION_base(4,9,0)+type NotWritable = 'Text "This attribute is not writable."+#endif++-- | Minimal block size in samples used in the stream.+--+-- __Read-only__ attribute represented as a 'Word32'.++data MinBlockSize = MinBlockSize++instance MetaValue MinBlockSize where+  type MetaType MinBlockSize = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable MinBlockSize = TypeError NotWritable+#endif+  retrieve MinBlockSize = inStreamInfo getMinBlockSize++-- | Maximal block size in samples used in the stream. Equality of minimum+-- block size and maximum block size implies a fixed-blocksize stream.+--+-- __Read-only__ attribute represented as a 'Word32'.++data MaxBlockSize = MaxBlockSize++instance MetaValue MaxBlockSize where+  type MetaType MaxBlockSize = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable MaxBlockSize = TypeError NotWritable+#endif+  retrieve MaxBlockSize = inStreamInfo getMaxBlockSize++-- | Minimal frame size in bytes used in the stream. May be 0 to imply the+-- value is not known.+--+-- __Read-only__ attribute represented as a 'Word32'.++data MinFrameSize = MinFrameSize++instance MetaValue MinFrameSize where+  type MetaType MinFrameSize = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable MinFrameSize = TypeError NotWritable+#endif+  retrieve MinFrameSize = inStreamInfo getMinFrameSize++-- | Maximal frame size in bytes used in the stream. May be 0 to imply the+-- value is not known.+--+-- __Read-only__ attribute represented as a 'Word32'.++data MaxFrameSize = MaxFrameSize++instance MetaValue MaxFrameSize where+  type MetaType MaxFrameSize = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable MaxFrameSize = TypeError NotWritable+#endif+  retrieve MaxFrameSize = inStreamInfo getMaxFrameSize++-- | Sample rate in Hz.+--+-- __Read-only__ attribute represented as a 'Word32'.++data SampleRate = SampleRate++instance MetaValue SampleRate where+  type MetaType SampleRate = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable SampleRate = TypeError NotWritable+#endif+  retrieve SampleRate = inStreamInfo getSampleRate++-- | Number of channels. FLAC supports from 1 to 8 channels.+--+-- __Read-only__ attribute represented as a 'Word32'.++data Channels = Channels++instance MetaValue Channels where+  type MetaType Channels = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable Channels = TypeError NotWritable+#endif+  retrieve Channels = inStreamInfo getChannels++-- | Channel mask specifying which speaker positions are present. This is+-- inferred from number of channels using channel assignment rules described+-- in the FLAC specification.+--+-- __Read-only__ attribute represented as @'Set' 'SpeakerPosition'@.++data ChannelMask = ChannelMask++instance MetaValue ChannelMask where+  type MetaType ChannelMask = Set SpeakerPosition+#if MIN_VERSION_base(4,9,0)+  type MetaWritable ChannelMask = TypeError NotWritable+#endif+  retrieve ChannelMask = toChannelMask <$> retrieve Channels++-- | Bits per sample (sample depth). FLAC supports from 4 to 32 bits per+-- sample. Currently the reference encoder and decoder only support up to 24+-- bits per sample.+--+-- __Read-only__ attribute represented as a 'Word32'.++data BitsPerSample = BitsPerSample++instance MetaValue BitsPerSample where+  type MetaType BitsPerSample = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable BitsPerSample = TypeError NotWritable+#endif+  retrieve BitsPerSample = inStreamInfo getBitsPerSample++-- | Total number of samples in audio stream. “Samples” means inter-channel+-- sample, i.e. one second of 44.1 KHz audio will have 44100 samples+-- regardless of the number of channels. A value of zero here means the+-- number of total samples is unknown.+--+-- __Read-only__ attribute represented as a 'Word64'.++data TotalSamples = TotalSamples++instance MetaValue TotalSamples where+  type MetaType TotalSamples = Word64+#if MIN_VERSION_base(4,9,0)+  type MetaWritable TotalSamples = TypeError NotWritable+#endif+  retrieve TotalSamples = inStreamInfo getTotalSamples++-- | File size in bytes.+--+-- __Read-only__ attribute represented as a 'Natural'.++data FileSize = FileSize++instance MetaValue FileSize where+  type MetaType FileSize = Natural+#if MIN_VERSION_base(4,9,0)+  type MetaWritable FileSize = TypeError NotWritable+#endif+  retrieve FileSize = FlacMeta (asks metaFileSize)++-- | Bit rate in kilo-bits per second (kbps).+--+-- __Read-only__ attribute represented as a 'Word32'.++data BitRate = BitRate++instance MetaValue BitRate where+  type MetaType BitRate = Word32+#if MIN_VERSION_base(4,9,0)+  type MetaWritable BitRate = TypeError NotWritable+#endif+  retrieve BitRate = do+    fileSize <- fromIntegral <$> retrieve FileSize+    duration <- retrieve Duration+    -- NOTE 8 / 1000 = 125, (* 8) to get bits, (/ 1000) to get kilos+    (return . floor) (fileSize / (duration * 125))++-- | MD5 signature of the unencoded audio data. This allows the decoder to+-- determine if an error exists in the audio data even when the error does+-- not result in an invalid bitstream.+--+-- __Read-only__ attribute represented as a 'ByteString' of length 16.++data MD5Sum = MD5Sum++instance MetaValue MD5Sum where+  type MetaType MD5Sum = ByteString+#if MIN_VERSION_base(4,9,0)+  type MetaWritable MD5Sum = TypeError NotWritable+#endif+  retrieve MD5Sum = inStreamInfo getMd5Sum++-- | Duration in seconds.+--+-- __Read-only__ attribute represented as a 'Double'.++data Duration = Duration++instance MetaValue Duration where+  type MetaType Duration = Double+#if MIN_VERSION_base(4,9,0)+  type MetaWritable Duration = TypeError NotWritable+#endif+  retrieve Duration = do+    totalSamples <- fromIntegral <$> retrieve TotalSamples+    sampleRate   <- fromIntegral <$> retrieve SampleRate+    return (totalSamples / sampleRate)++-- | Application metadata. The 'ApplicationId' argument to 'Application'+-- data constructor can be written using usual Haskell syntax for 'String'+-- literals, just make sure to enable the @OverloadedStrings@ extension.+--+-- For the list of defined application IDs, see:+--+-- <https://xiph.org/flac/id.html>.+--+-- __Writable__ optional attribute represented as a @'Maybe' 'ByteString'@.++data Application = Application ApplicationId++instance MetaValue Application where+  type MetaType Application = Maybe ByteString+  type MetaWritable Application = ()+  retrieve (Application appId) =+    FlacMeta . withApplicationBlock appId $+      liftIO . (iteratorGetBlock >=> getApplicationData)+  Application appId =-> Nothing =+    void . FlacMeta . withApplicationBlock appId $ \i -> do+      liftBool (iteratorDeleteBlock i)+      setModified+  Application appId =-> Just data' =+    FlacMeta . withApplicationBlock' appId $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setApplicationData block data')+      setModified++-- | Seek table as a 'Vector' of 'SeekPoint's. Seek points within a table+-- must be sorted in ascending order by sample number. If you try to write+-- an invalid seek table, 'MetaException' will be raised using+-- 'MetaInvalidSeekTable' constructor.+--+-- __Writable__ optional attribute represented as a @'Maybe' ('Vector'+-- 'SeekPoint')@.++data SeekTable = SeekTable++instance MetaValue SeekTable where+  type MetaType SeekTable = Maybe (Vector SeekPoint)+  type MetaWritable SeekTable = ()+  retrieve SeekTable =+    FlacMeta . withMetaBlock SeekTableBlock $+      liftIO . (iteratorGetBlock >=> getSeekPoints)+  SeekTable =-> Nothing =+    void . FlacMeta . withMetaBlock SeekTableBlock $ \i -> do+      liftBool (iteratorDeleteBlock i)+      setModified+  SeekTable =-> Just seekPoints =+    FlacMeta . withMetaBlock' SeekTableBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setSeekPoints block seekPoints)+      setModified++-- | Vorbis “vendor” comment. When “Vorbis Comment” metadata block is+-- present, the “vendor” entry is always in there, so when you delete it (by+-- @'VorbisVendor' '=->' 'Nothing'@), you really set it to an empty string+-- (which is enough to trigger auto vacuum feature if no other entries are+-- detected, see 'metaAutoVacuum').+--+-- __Writable__ optional attribute represented as a @'Maybe' 'Text'@.++data VorbisVendor = VorbisVendor++instance MetaValue VorbisVendor where+  type MetaType VorbisVendor = Maybe Text+  type MetaWritable VorbisVendor = ()+  retrieve VorbisVendor =+    FlacMeta . withMetaBlock VorbisCommentBlock $+      liftIO . (iteratorGetBlock >=> getVorbisVendor)+  VorbisVendor =-> Nothing =+    void . FlacMeta . withMetaBlock VorbisCommentBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setVorbisVendor block "")+      setModified+  VorbisVendor =-> (Just value) =+    FlacMeta . withMetaBlock' VorbisCommentBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setVorbisVendor block value)+      setModified++-- | Various Vorbis comments, see 'VorbisField' for available field names.+-- The field names are mostly taken from here:+--+-- <https://www.xiph.org/vorbis/doc/v-comment.html>.+--+-- 'TrackTotal', 'DiscNumber', and 'Rating' are popular de-facto standard+-- fields. The library also supports the standard ReplayGain comments.+--+-- __Writable__ optional attribute represented as a @'Maybe' 'Text'@.++data VorbisComment = VorbisComment VorbisField++-- | Enumeration of all supported filed names to index vorbis comment+-- entries.++data VorbisField+  = Title              -- ^ Track\/Work name.+  | Version            -- ^ The version field may be used to differentiate+                       -- multiple versions of the same track title in a+                       -- single collection (e.g. remix info).+  | Album              -- ^ The collection name to which this track belongs+  | TrackNumber        -- ^ The track number of this piece if part of a+                       -- specific larger collection or album.+  | TrackTotal         -- ^ Total number of tracks in the collection this+                       -- track belongs to.+  | DiscNumber         -- ^ Disc number in a multi-disc release.+  | Artist             -- ^ The artist generally considered responsible for+                       -- the work. In popular music this is usually the+                       -- performing band or singer. For classical music it+                       -- would be the composer. For an audio book it would+                       -- be the author of the original text.+  | Performer          -- ^ The artist(s) who performed the work. In+                       -- classical music this would be the conductor,+                       -- orchestra, soloists. In an audio book it would be+                       -- the actor who did the reading. In popular music+                       -- this is typically the same as the 'Artist' and is+                       -- omitted.+  | Copyright          -- ^ Copyright attribution, e.g., “2001 Nobody's+                       -- Band” or “1999 Jack Moffitt”.+  | License            -- ^ License information, e.g., “All Rights+                       -- Reserved”, “Any Use Permitted”, a URL to a license+                       -- such as a Creative Commons license or the EFF Open+                       -- Audio License, etc.+  | Organization       -- ^ Name of the organization producing the track+                       -- (i.e. the “record label”).+  | Description        -- ^ A short text description of the contents.+  | Genre              -- ^ A short text indication of music genre.+  | Date               -- ^ Date the track was recorded, usually year.+  | Location           -- ^ Location where track was recorded.+  | Contact            -- ^ Contact information for the creators or+                       -- distributors of the track. This could be a URL, an+                       -- email address, the physical address of the+                       -- producing label.+  | ISRC               -- ^ ISRC number for the track, see <http://isrc.ifpi.org/en>.+  | Rating             -- ^ Rating, usually mapped as 1–5 stars with actual+                       -- values “20”, “40”, “60”, “80”, “100” stored.+  | RGTrackPeak        -- ^ Replay gain track peak, e.g. “0.99996948”.+  | RGTrackGain        -- ^ Replay gain track gain, e.g. “-7.89 dB”.+  | RGAlbumPeak        -- ^ Replay gain album peak, e.g. “0.99996948”.+  | RGAlbumGain        -- ^ Replay gain album gain, e.g. “-7.89 dB”.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++instance MetaValue VorbisComment where+  type MetaType VorbisComment = Maybe Text+  type MetaWritable VorbisComment = ()+  retrieve (VorbisComment field) =+    FlacMeta . fmap join . withMetaBlock VorbisCommentBlock $+      liftIO . (iteratorGetBlock >=> getVorbisComment (vorbisFieldName field))+  VorbisComment field =-> Nothing =+    void . FlacMeta . withMetaBlock VorbisCommentBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (deleteVorbisComment (vorbisFieldName field) block)+      setModified+  VorbisComment field =-> Just value =+    FlacMeta . withMetaBlock' VorbisCommentBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setVorbisComment (vorbisFieldName field) value block)+      setModified++-- | A CUE sheet stored in FLAC metadata. If you try to write an invalid CUE+-- sheet 'MetaException' will be raised with 'MetaInvalidCueSheet'+-- constructor which includes a 'Text' value with explanation why the CUE+-- sheet was considered invalid. Import "Codec.Audio.FLAC.Metadata.CueSheet"+-- to manipulate 'CueSheetData' and 'CueTrack's.+--+-- __Writable__ optional attribute represented as a @'Maybe' 'CueSheetData'@.++data CueSheet = CueSheet++instance MetaValue CueSheet where+  type MetaType CueSheet = Maybe CueSheetData+  type MetaWritable CueSheet = ()+  retrieve CueSheet =+    FlacMeta . withMetaBlock CueSheetBlock $+      liftIO . (iteratorGetBlock >=> getCueSheetData)+  CueSheet =-> Nothing =+    void . FlacMeta . withMetaBlock CueSheetBlock $ \i -> do+      liftBool (iteratorDeleteBlock i)+      setModified+  CueSheet =-> Just cueSheetData =+    FlacMeta . withMetaBlock' CueSheetBlock $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setCueSheetData block cueSheetData)+      setModified++-- | Picture embedded in FLAC file. A FLAC file can have several pictures+-- attached to it, you choose which one you want by specifying+-- 'PictureType'. If you try to write an invalid picture 'MetaException'+-- will be raised with 'MetaInvalidPicture' constructor which includes a+-- 'Text' value with explanation why the picture was considered invalid.+--+-- Note that the @flac-picture@+-- <https://hackage.haskell.org/package/flac-picture> package allows to work+-- with 'PictureData' easier using the @Juicy-Pixels@ library.+--+-- __Writable__ optional attribute represented as a @'Maybe' 'PictureData'@.++data Picture = Picture PictureType++instance MetaValue Picture where+  type MetaType Picture = Maybe PictureData+  type MetaWritable Picture = ()+  retrieve (Picture pictureType) =+    FlacMeta . withPictureBlock pictureType $+      liftIO . (iteratorGetBlock >=> getPictureData)+  Picture pictureType =-> Nothing =+    void . FlacMeta . withPictureBlock pictureType $ \i -> do+      liftBool (iteratorDeleteBlock i)+      setModified+  Picture pictureType =-> Just pictureData =+    void . FlacMeta . withPictureBlock' pictureType $ \i -> do+      block <- liftIO (iteratorGetBlock i)+      liftBool (setPictureData block pictureData)+      setModified++----------------------------------------------------------------------------+-- Extra functionality++-- | Delete all “Vorbis comment” metadata blocks.++wipeVorbisComment :: FlacMeta ()+wipeVorbisComment =+  void . FlacMeta . withMetaBlock VorbisCommentBlock $ \i -> do+    liftBool (iteratorDeleteBlock i)+    setModified++-- | Delete all “Application” metadata blocks.++wipeApplications :: FlacMeta ()+wipeApplications =+  void . FlacMeta . withMetaBlock ApplicationBlock $ \i -> do+    liftBool (iteratorDeleteBlock i)+    setModified++-- | Delete all “Seek table” metadata blocks.++wipeSeekTable :: FlacMeta ()+wipeSeekTable =+  void . FlacMeta . withMetaBlock SeekTableBlock $ \i -> do+    liftBool (iteratorDeleteBlock i)+    setModified++-- | Delete all “CUE sheet” metadata blocks.++wipeCueSheets :: FlacMeta ()+wipeCueSheets =+  void . FlacMeta . withMetaBlock CueSheetBlock $ \i -> do+    liftBool (iteratorDeleteBlock i)+    setModified++-- | Delete all “Picture” metadata blocks.++wipePictures :: FlacMeta ()+wipePictures =+  void . FlacMeta . withMetaBlock PictureBlock $ \i -> do+    liftBool (iteratorDeleteBlock i)+    setModified++----------------------------------------------------------------------------+-- Debugging and testing++-- | Return list of all 'MetadataType's of metadata blocks detected in+-- order.++getMetaChain :: FlacMeta (NonEmpty MetadataType)+getMetaChain = FlacMeta $ do+  chain <- asks metaChain+  NE.fromList <$> withIterator chain (fmap Just . liftIO . iteratorGetBlockType)++-- | Return 'True' if actions in current 'FlacMeta' context have modified+-- FLAC metadata. If so, the FLAC file will be updated to reflect these+-- changes on the way out from the 'FlacMeta' monad.++isMetaChainModified :: FlacMeta Bool+isMetaChainModified = FlacMeta (asks metaModified >>= liftIO . readIORef)++----------------------------------------------------------------------------+-- Helpers++-- | A helper that takes a function that extracts something from 'Metadata'+-- block. It finds the 'StreamInfoBlock', gets 'Metadata' from it and+-- applies given function to get the final value.++inStreamInfo :: (Metadata -> IO a) -> FlacMeta a+inStreamInfo f =+  FlacMeta . fmap fromJust . withMetaBlock StreamInfoBlock $+    liftIO . (iteratorGetBlock >=> f)++-- | Given 'MetadataType' (type of metadata block) and an action that uses+-- an iterator which points to a block of specified type, perform that+-- action and return its result wrapped in 'Just' if block of requested type+-- was found, 'Nothing' otherwise. If there are several blocks of given+-- type, action will be performed for each of them, but only first result+-- will be returned.++withMetaBlock+  :: MetadataType      -- ^ Type of block to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner (Maybe a)   -- ^ Result in 'Just' if block was found+withMetaBlock = withMetaBlockGen noCheck+  where+    noCheck _ = return True++-- | Just like 'withMetaBlock', but creates a new block of requested type if+-- no block of such type can be found.++withMetaBlock'+  :: MetadataType      -- ^ Type of block to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner a           -- ^ Result+withMetaBlock' = withMetaBlockGen' noCheck noSet+  where+    noCheck _ = return True+    noSet   _ = return ()++-- | The same as 'withMetaBlock' but it searches for a block of type+-- 'ApplicationBlock' that has specified application id.++withApplicationBlock+  :: ApplicationId     -- ^ Application id to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner (Maybe a)   -- ^ Result in 'Just' if block was found+withApplicationBlock givenId =+  withMetaBlockGen idCheck ApplicationBlock+  where+    idCheck = fmap (== givenId) . liftIO . getApplicationId++-- | Just like 'applicationBlock', but creates a new 'ApplicationBlock' with+-- given id if no such block can be found.++withApplicationBlock'+  :: ApplicationId     -- ^ Application id to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner a           -- ^ Result+withApplicationBlock' givenId =+  withMetaBlockGen' idCheck setId ApplicationBlock+  where+    idCheck     = fmap (== givenId) . liftIO . getApplicationId+    setId block = liftIO (setApplicationId block givenId)++-- | The same as 'withMetaBlock', but it searches for a block of type+-- 'PictureBlock' that has specific 'PictureType'.++withPictureBlock+  :: PictureType       -- ^ Picture type to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner (Maybe a)   -- ^ Result in 'Just' if block was found+withPictureBlock givenType = withMetaBlockGen typeCheck PictureBlock+  where+    typeCheck = fmap (== givenType) . liftIO . getPictureType++-- | Just like 'withPictureBlock', but creates a new 'PictureBlock' with+-- given 'PictureType' if no such block can be found.++withPictureBlock'+  :: PictureType       -- ^ Picture type to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner a           -- ^ Result in 'Just'+withPictureBlock' givenType =+  withMetaBlockGen' typeCheck setType PictureBlock+  where+    typeCheck = fmap (== givenType) . liftIO . getPictureType+    setType block = liftIO (setPictureType block givenType)++-- | A generic building block for 'withMetaBlock'-like helpers.++withMetaBlockGen+  :: (Metadata -> Inner Bool) -- ^ Additional check on 'Metadata' block+  -> MetadataType      -- ^ Type of block to find+  -> (MetaIterator -> Inner a) -- ^ What to do if such block found+  -> Inner (Maybe a)   -- ^ Result in 'Just' if block was found+withMetaBlockGen check givenType f = do+  chain <- asks metaChain+  fmap listToMaybe . withIterator chain $ \i -> do+    actualType <- liftIO (iteratorGetBlockType i)+    if actualType == givenType+      then do+        block <- liftIO (iteratorGetBlock i)+        match <- check block+        if match+          then Just <$> f i+          else return Nothing+      else return Nothing++-- | A generic building block for 'withMetaBlock''-like helpers.++withMetaBlockGen'+  :: (Metadata -> Inner Bool)+     -- ^ Additional check on 'Metadata' block+  -> (Metadata -> Inner ())+     -- ^ Set parameters of newly created block before calling the main callback+  -> MetadataType+     -- ^ Type of block to find+  -> (MetaIterator -> Inner a)+     -- ^ What to do if such block found (main callback)+  -> Inner a+withMetaBlockGen' check setParam givenType f = do+  chain <- asks metaChain+  res   <- withMetaBlockGen check givenType f+  case res of+    Nothing -> fmap head . withIterator chain $ \i -> do+      actual <- liftIO (iteratorGetBlockType i)+      if actual == StreamInfoBlock+        then+          let acquire = liftMaybe (objectNew givenType)+              release = liftIO . objectDelete+          in do+            bracketOnError acquire release $ \block -> do+              setParam block+              liftBool (iteratorInsertBlockAfter i block)+            Just <$> f i+        else return Nothing+    Just x -> return x++-- | Go through all metadata blocks and delete empty ones.++applyVacuum :: Inner ()+applyVacuum = do+  chain <- asks metaChain+  void . withIterator chain $ \i -> do+    blockType <- liftIO (iteratorGetBlockType i)+    block     <- liftIO (iteratorGetBlock     i)+    empty     <- liftIO (isMetaBlockEmpty blockType block)+    when empty $+      liftBool (iteratorDeleteBlock i)+    return Nothing++-- | Determine if given metadata block is empty.++isMetaBlockEmpty :: MonadIO m => MetadataType -> Metadata -> m Bool+isMetaBlockEmpty SeekTableBlock block =+  V.null <$> liftIO (getSeekPoints block)+isMetaBlockEmpty VorbisCommentBlock block =+  liftIO (isVorbisCommentEmpty block)+isMetaBlockEmpty _ _ = return False++-- | Lift an action that may return 'Nothing' on failure into 'Inner' monad+-- taking care of error reporting.++liftMaybe :: IO (Maybe a) -> Inner a+liftMaybe m = liftIO m >>= maybe throwStatus return++-- | Lift an action that returns 'False' on failure into 'Inner' monad+-- taking care of error reporting.++liftBool :: IO Bool -> Inner ()+liftBool m = liftIO m >>= bool throwStatus (return ())++-- | Get 'MetaChainStatus' and throw it immediately.++throwStatus :: Inner a+throwStatus = do+  chain  <- asks metaChain+  status <- liftIO (chainStatus chain)+  throwM (MetaGeneralProblem status)++-- | Specify that the metadata chain has been modified.++setModified :: Inner ()+setModified = do+  modified <- asks metaModified+  liftIO (writeIORef modified True)++-- | Map 'VorbisField' to its ASCII name in form of a 'ByteString'.++vorbisFieldName :: VorbisField -> ByteString+vorbisFieldName RGTrackPeak = "REPLAYGAIN_TRACK_PEAK"+vorbisFieldName RGTrackGain = "REPLAYGAIN_TRACK_GAIN"+vorbisFieldName RGAlbumPeak = "REPLAYGAIN_ALBUM_PEAK"+vorbisFieldName RGAlbumGain = "REPLAYGAIN_ALBUM_GAIN"+vorbisFieldName field = (B8.pack . fmap toUpper . show) field++-- | Map number of channels to a 'Set' of 'SpeakerPosition's as per FLAC+-- specification.++toChannelMask :: Word32 -> Set SpeakerPosition+toChannelMask n = case n of+  0 -> E.empty+  1 -> speakerMono+  2 -> speakerStereo+  3 -> E.fromList [SpeakerFrontLeft,SpeakerFrontRight,SpeakerFrontCenter]+  4 -> speakerQuad+  5 -> E.insert SpeakerFrontCenter speakerQuad+  6 -> speaker5_1+  7 -> E.insert SpeakerBackCenter speaker5_1Surround+  8 -> speaker7_1Surround+  x -> E.fromList $ take (fromIntegral x) [minBound..maxBound]
+ Codec/Audio/FLAC/Metadata/CueSheet.hs view
@@ -0,0 +1,19 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata.CueSheet+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- This module exports the 'CueSheetData' and 'CueTrack' data types, which+-- are rarely needed, and thus should not “contaminate” the+-- "Codec.Audio.Metadata" module with potentially conflicting names.++module Codec.Audio.FLAC.Metadata.CueSheet+  ( CueSheetData (..)+  , CueTrack (..) )+where++import Codec.Audio.FLAC.Metadata.Internal.Types
+ Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs view
@@ -0,0 +1,245 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata.Internal.Level2Interface+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Low-level Haskell wrapper around C functions to work with level 2 FLAC+-- metadata interface, see:+--+-- <https://xiph.org/flac/api/group__flac__metadata__level2.html>.++{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Codec.Audio.FLAC.Metadata.Internal.Level2Interface+  ( -- * Chain+    withChain+  , chainStatus+  , chainRead+  , chainWrite+  , chainSortPadding+    -- * Iterator+  , withIterator+  , iteratorGetBlockType+  , iteratorGetBlock+  , iteratorSetBlock+  , iteratorDeleteBlock+  , iteratorInsertBlockAfter )+where++import Codec.Audio.FLAC.Metadata.Internal.Types+import Codec.Audio.FLAC.Util+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO (..))+import Foreign.C.String+import Foreign.C.Types+import Prelude hiding (iterate)++----------------------------------------------------------------------------+-- Chain++-- | Create and use a 'MetaChain' (metadata chain). The chain is guaranteed+-- to be freed even in case of exception.+--+-- If memory for the chain cannot be allocated, corresponding+-- 'MetaException' is raised.++withChain :: (MetaChain -> IO a) -> IO a+withChain f = bracket chainNew (mapM_ chainDelete) $ \mchain ->+  case mchain of+    Nothing -> throwM+      (MetaGeneralProblem MetaChainStatusMemoryAllocationError)+    Just x -> f x++-- | Create a new 'MetaChain'. In the case of memory allocation problem+-- 'Nothing' is returned.++chainNew :: IO (Maybe MetaChain)+chainNew = maybePtr <$> c_chain_new++foreign import ccall unsafe "FLAC__metadata_chain_new"+  c_chain_new :: IO MetaChain++-- | Free a chain instance. Deletes the object pointed to by chain.++chainDelete :: MetaChain -> IO ()+chainDelete = c_chain_delete++foreign import ccall unsafe "FLAC__metadata_chain_delete"+  c_chain_delete :: MetaChain -> IO ()++-- | Check status of given 'MetaChain'. This can be used to find out what+-- went wrong. Also resets status to 'MetaChainStatusOK'.++chainStatus :: MetaChain -> IO MetaChainStatus+chainStatus = fmap toEnum' . c_chain_status++foreign import ccall unsafe "FLAC__metadata_chain_status"+  c_chain_status :: MetaChain -> IO CUInt++-- | Read all metadata from a FLAC file into the chain. Return 'False' if+-- something went wrong.++chainRead :: MetaChain -> FilePath -> IO Bool+chainRead chain path = withCString path (c_chain_read chain)++foreign import ccall unsafe "FLAC__metadata_chain_read"+  c_chain_read :: MetaChain -> CString -> IO Bool++-- | Write all metadata out to the FLAC file.++chainWrite+  :: MetaChain         -- ^ The chain to write+  -> Bool              -- ^ Whether to use padding+  -> Bool              -- ^ Whether to preserve file stats+  -> IO Bool           -- ^ 'False' if something went wrong+chainWrite chain usePadding preserveStats =+  c_chain_write chain (fromEnum' usePadding) (fromEnum' preserveStats)++foreign import ccall unsafe "FLAC__metadata_chain_write"+  c_chain_write :: MetaChain -> CInt -> CInt -> IO Bool++-- | Move all padding blocks to the end on the metadata, then merge them+-- into a single block. Useful to get maximum padding to have better changes+-- for re-writing only metadata blocks, not entire FLAC file. Any iterator+-- on the current chain will become invalid after this call. You should+-- delete the iterator and get a new one.+--+-- Note: this function does not write to the FLAC file, it only modifies the+-- chain.++chainSortPadding :: MetaChain -> IO ()+chainSortPadding = c_chain_sort_padding++foreign import ccall unsafe "FLAC__metadata_chain_sort_padding"+  c_chain_sort_padding :: MetaChain -> IO ()++----------------------------------------------------------------------------+-- Iterator++-- | Traverse all metadata blocks from beginning to end collecting 'Just'+-- values and possibly performing some actions. This is the only way to+-- traverse metadata chain and get access to 'MetaIterator' and by exporting+-- only this, we eliminate certain class of possible errors making finding+-- and traversing metadata blocks always correct and safe.+--+-- If memory for the iterator cannot be allocated, corresponding+-- 'MetaException' is raised.++withIterator :: (MonadMask m, MonadIO m)+  => MetaChain         -- ^ Metadata chain to traverse+  -> (MetaIterator -> m (Maybe a)) -- ^ Action to perform on each block+  -> m [a]             -- ^ Accumulated results+withIterator chain f = bracket acquire release action+  where+    acquire = liftIO iteratorNew+    release = mapM_ (liftIO . iteratorDelete)+    action mi =+      case mi of+        Nothing -> throwM+          (MetaGeneralProblem MetaChainStatusMemoryAllocationError)+        Just i -> do+          liftIO (iteratorInit i chain)+          let go thisNext =+                if thisNext+                  then do+                    res <- f i+                    let next = liftIO (iteratorNext i) >>= go+                    case res of+                      Nothing -> next+                      Just  x -> (x :) <$> next+                  else return []+          go True++-- | Create a new iterator. Return 'Nothing' if there was a problem with+-- memory allocation.++iteratorNew :: IO (Maybe MetaIterator)+iteratorNew = maybePtr <$> c_iterator_new++foreign import ccall unsafe "FLAC__metadata_iterator_new"+  c_iterator_new :: IO MetaIterator++-- | Free an iterator instance. Deletes the object pointed to by+-- 'MetaIterator'.++iteratorDelete :: MetaIterator -> IO ()+iteratorDelete = c_iterator_delete++foreign import ccall unsafe "FLAC__metadata_iterator_delete"+  c_iterator_delete :: MetaIterator -> IO ()++-- | Initialize the iterator to point to the first metadata block in the+-- given chain.++iteratorInit+  :: MetaIterator      -- ^ Existing iterator+  -> MetaChain         -- ^ Existing initialized chain+  -> IO ()+iteratorInit = c_iterator_init++foreign import ccall unsafe "FLAC__metadata_iterator_init"+  c_iterator_init :: MetaIterator -> MetaChain -> IO ()++-- | Move the iterator forward one metadata block, returning 'False' if+-- already at the end.++iteratorNext :: MetaIterator -> IO Bool+iteratorNext = c_iterator_next++foreign import ccall unsafe "FLAC__metadata_iterator_next"+  c_iterator_next :: MetaIterator -> IO Bool++-- | Get the type of the metadata block at the current position. Useful for+-- fast searching.++iteratorGetBlockType :: MetaIterator -> IO MetadataType+iteratorGetBlockType = fmap toEnum' . c_iterator_get_block_type++foreign import ccall unsafe "FLAC__metadata_iterator_get_block_type"+  c_iterator_get_block_type :: MetaIterator -> IO CUInt++-- | Get metadata block at the current position.++iteratorGetBlock :: MetaIterator -> IO Metadata+iteratorGetBlock = c_iterator_get_block++foreign import ccall unsafe "FLAC__metadata_iterator_get_block"+  c_iterator_get_block :: MetaIterator -> IO Metadata++-- | Write given 'Metadata' block at position pointed to by 'MetaIterator'+-- replacing existing block.++iteratorSetBlock :: MetaIterator -> Metadata -> IO Bool+iteratorSetBlock = c_iterator_set_block++foreign import ccall unsafe "FLAC__metadata_iterator_set_block"+  c_iterator_set_block :: MetaIterator -> Metadata -> IO Bool++-- | Remove the current block from the chain.++iteratorDeleteBlock+  :: MetaIterator      -- ^ Iterator that determines the position+  -> IO Bool           -- ^ 'False' if something went wrong+iteratorDeleteBlock block = c_iterator_delete_block block False++foreign import ccall unsafe "FLAC__metadata_iterator_delete_block"+  c_iterator_delete_block :: MetaIterator -> Bool -> IO Bool++-- | Insert a new block after the current block. You cannot insert a+-- 'StreamInfo' block as there can be only one, the one that already exists+-- at the head when you read in a chain. The chain takes ownership of the+-- new block and it will be deleted when the chain is deleted. The iterator+-- will be left pointing to the new block.+--+-- The function returns 'False' if something went wrong.++iteratorInsertBlockAfter :: MetaIterator -> Metadata -> IO Bool+iteratorInsertBlockAfter = c_iterator_insert_block_after++foreign import ccall unsafe "FLAC__metadata_iterator_insert_block_after"+  c_iterator_insert_block_after :: MetaIterator -> Metadata -> IO Bool
+ Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs view
@@ -0,0 +1,584 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Wrappers around helpers for working with level 2 FLAC metadata interface.+--+-- The functions from this module are not safe, one only should attempt+-- calling them when 'Metadata' contains metadata of correct type.++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE TupleSections            #-}++module Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers+  ( -- * Stream info+    getMinBlockSize+  , getMaxBlockSize+  , getMinFrameSize+  , getMaxFrameSize+  , getSampleRate+  , getChannels+  , getBitsPerSample+  , getTotalSamples+  , getMd5Sum+    -- * Application+  , getApplicationId+  , getApplicationData+  , setApplicationId+  , setApplicationData+    -- * Seek table+  , getSeekPoints+  , setSeekPoints+    -- * Vorbis comment+  , getVorbisVendor+  , setVorbisVendor+  , getVorbisComment+  , setVorbisComment+  , deleteVorbisComment+  , isVorbisCommentEmpty+    -- * CUE sheet+  , getCueSheetData+  , setCueSheetData+    -- * Picture+  , getPictureType+  , getPictureData+  , setPictureType+  , setPictureData )+where++import Codec.Audio.FLAC.Metadata.Internal.Object+import Codec.Audio.FLAC.Metadata.Internal.Types+import Codec.Audio.FLAC.Util+import Control.Monad+import Control.Monad.Catch+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.List (uncons)+import Data.Maybe (isJust)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Vector (Vector, (!))+import Data.Word+import Foreign+import Foreign.C.String+import Foreign.C.Types+import qualified Data.ByteString     as B+import qualified Data.List.NonEmpty  as NE+import qualified Data.Text           as T+import qualified Data.Text.Encoding  as T+import qualified Data.Text.Foreign   as T+import qualified Data.Vector         as V+import qualified Data.Vector.Mutable as VM++----------------------------------------------------------------------------+-- Stream info++-- | Get min block size.++getMinBlockSize :: Metadata -> IO Word32+getMinBlockSize = fmap fromIntegral . c_get_min_blocksize++foreign import ccall unsafe "FLAC__metadata_get_min_blocksize"+  c_get_min_blocksize :: Metadata -> IO CUInt++-- | Get max block size.++getMaxBlockSize :: Metadata -> IO Word32+getMaxBlockSize = fmap fromIntegral . c_get_max_blocksize++foreign import ccall unsafe "FLAC__metadata_get_max_blocksize"+  c_get_max_blocksize :: Metadata -> IO CUInt++-- | Get min frame size.++getMinFrameSize :: Metadata -> IO Word32+getMinFrameSize = fmap fromIntegral . c_get_min_framesize++foreign import ccall unsafe "FLAC__metadata_get_min_framesize"+  c_get_min_framesize :: Metadata -> IO Word32++-- | Get max frame size.++getMaxFrameSize :: Metadata -> IO Word32+getMaxFrameSize = fmap fromIntegral . c_get_max_framesize++foreign import ccall unsafe "FLAC__metadata_get_max_framesize"+  c_get_max_framesize :: Metadata -> IO Word32++-- | Get sample rate.++getSampleRate :: Metadata -> IO Word32+getSampleRate = fmap fromIntegral . c_get_sample_rate++foreign import ccall unsafe "FLAC__metadata_get_sample_rate"+  c_get_sample_rate :: Metadata -> IO CUInt++-- | Get number of channels.++getChannels :: Metadata -> IO Word32+getChannels = fmap fromIntegral . c_get_channels++foreign import ccall unsafe "FLAC__metadata_get_channels"+  c_get_channels :: Metadata -> IO CUInt++-- | Get number of bits per sample.++getBitsPerSample :: Metadata -> IO Word32+getBitsPerSample = fmap fromIntegral . c_get_bits_per_sample++foreign import ccall unsafe "FLAC__metadata_get_bits_per_sample"+  c_get_bits_per_sample :: Metadata -> IO CUInt++-- | Get total number of samples.++getTotalSamples :: Metadata -> IO Word64+getTotalSamples = c_get_total_samples++foreign import ccall unsafe "FLAC__metadata_get_total_samples"+  c_get_total_samples :: Metadata -> IO Word64++-- | Get MD5 sum of original audio data.++getMd5Sum :: Metadata -> IO ByteString+getMd5Sum block = do+  md5SumPtr <- c_get_md5sum block+  B.packCStringLen (md5SumPtr, 16)++foreign import ccall unsafe "FLAC__metadata_get_md5sum"+  c_get_md5sum :: Metadata -> IO CString++----------------------------------------------------------------------------+-- Application++-- | Get application id from given 'Metadata' block.++getApplicationId :: Metadata -> IO ApplicationId+getApplicationId block = do+  idPtr <- c_get_application_id block+  mkApplicationId <$> B.packCStringLen (idPtr, 4)++foreign import ccall unsafe "FLAC__metadata_get_application_id"+  c_get_application_id :: Metadata -> IO CString++-- | Get data from given application metadata block.++getApplicationData :: Metadata -> IO ByteString+getApplicationData block = alloca $ \sizePtr -> do+  dataPtr <- c_get_application_data block sizePtr+  size    <- fromIntegral <$> peek sizePtr+  B.packCStringLen (dataPtr, size)++foreign import ccall unsafe "FLAC__metadata_get_application_data"+  c_get_application_data :: Metadata -> Ptr CUInt -> IO CString++-- | Set application id for given metadata block.++setApplicationId :: Metadata -> ApplicationId -> IO ()+setApplicationId block appId =+  B.useAsCString (unApplicationId appId) (c_set_application_id block)++foreign import ccall unsafe "FLAC__metadata_set_application_id"+  c_set_application_id :: Metadata -> CString -> IO ()++-- | Set application data for given metadata block.++setApplicationData :: Metadata -> ByteString -> IO Bool+setApplicationData block data' =+  B.useAsCString data' $ \dataPtr -> do+    let size = fromIntegral (B.length data')+    c_set_application_data block dataPtr size++foreign import ccall unsafe "FLAC__metadata_set_application_data"+  c_set_application_data :: Metadata -> CString -> CUInt -> IO Bool++----------------------------------------------------------------------------+-- Seek table++-- | Get seek table as a 'Vector' of 'SeekPoint's.++getSeekPoints :: Metadata -> IO (Vector SeekPoint)+getSeekPoints block = do+  size <- fromIntegral <$> c_get_seek_points_num block+  v    <- VM.new size+  let go n =+        when (n < size) $ do+          ptr <- c_get_seek_point block (fromIntegral n)+          seekPointSampleNumber <- peekByteOff ptr 0+          seekPointStreamOffset <- peekByteOff ptr 8+          seekPointFrameSamples <- peekByteOff ptr 16+          VM.write v n SeekPoint {..}+          go (n + 1)+  go 0+  V.unsafeFreeze v++foreign import ccall unsafe "FLAC__metadata_get_seek_points_num"+  c_get_seek_points_num :: Metadata -> IO CUInt++foreign import ccall unsafe "FLAC__metadata_get_seek_point"+  c_get_seek_point :: Metadata -> CUInt -> IO (Ptr SeekPoint)++-- | Set seek table represented by a given 'Vector' of 'SeekPoint's. Return+-- 'False' in case of trouble.++setSeekPoints :: Metadata -> Vector SeekPoint -> IO Bool+setSeekPoints block seekPoints = do+  let size = fromIntegral (V.length seekPoints)+  res <- objectSeektableResizePoints block size+  if res+    then+      let go n =+            if n < size+              then do+                let SeekPoint {..} = seekPoints ! fromIntegral n+                c_set_seek_point block (fromIntegral n)+                  seekPointSampleNumber+                  seekPointStreamOffset+                  seekPointFrameSamples+                go (n + 1)+              else do+                legal <- objectSeektableIsLegal block+                unless legal $+                  throwM MetaInvalidSeekTable+      in go 0 >> return True+    else return False++foreign import ccall unsafe "FLAC__metadata_set_seek_point"+  c_set_seek_point :: Metadata -> CUInt -> Word64 -> Word64 -> Word32 -> IO ()++----------------------------------------------------------------------------+-- Vorbis comment++-- | Get Vorbis vendor.++getVorbisVendor :: Metadata -> IO Text+getVorbisVendor block = alloca $ \sizePtr -> do+  vendorPtr <- c_get_vorbis_vendor block sizePtr+  size      <- fromIntegral <$> peek sizePtr+  T.peekCStringLen (vendorPtr, size)++foreign import ccall unsafe "FLAC__metadata_get_vorbis_vendor"+  c_get_vorbis_vendor :: Metadata -> Ptr Word32 -> IO CString++-- | Set Vorbis vendor.++setVorbisVendor :: Metadata -> Text -> IO Bool+setVorbisVendor block vendor =+  T.withCStringLen vendor $ \(vendorPtr, size) ->+    c_set_vorbis_vendor block vendorPtr (fromIntegral size)++foreign import ccall unsafe "FLAC__metadata_set_vorbis_vendor"+  c_set_vorbis_vendor :: Metadata -> CString -> Word32 -> IO Bool++-- | Get vorbis comment by name.++getVorbisComment :: ByteString -> Metadata -> IO (Maybe Text)+getVorbisComment name block = alloca $ \sizePtr ->+  B.useAsCString name $ \namePtr -> do+    commentPtr  <- c_get_vorbis_comment block namePtr sizePtr+    commentSize <- fromIntegral <$> peek sizePtr+    if commentPtr == nullPtr+      then return Nothing+      else do+        value <- T.drop 1 . T.dropWhile (/= '=') . T.decodeUtf8+          <$> B.packCStringLen (commentPtr, commentSize)+        return (pure value)++foreign import ccall unsafe "FLAC__metadata_get_vorbis_comment"+  c_get_vorbis_comment :: Metadata -> CString -> Ptr Word32 -> IO CString++-- | Set (replace or insert if necessary) a vorbis comment.++setVorbisComment :: ByteString -> Text -> Metadata -> IO Bool+setVorbisComment name value block =+  T.withCStringLen (T.decodeUtf8 name <> "=" <> value) $+    \(commentPtr, commentSize) ->+      c_set_vorbis_comment block commentPtr (fromIntegral commentSize)++foreign import ccall unsafe "FLAC__metadata_set_vorbis_comment"+  c_set_vorbis_comment :: Metadata -> CString -> Word32 -> IO Bool++-- | Delete a vorbis comment by name. If it doesn't exist, nothing will+-- happen.++deleteVorbisComment :: ByteString -> Metadata -> IO Bool+deleteVorbisComment name block =+  B.useAsCString name (c_delete_vorbis_comment block)++foreign import ccall unsafe "FLAC__metadata_delete_vorbis_comment"+  c_delete_vorbis_comment :: Metadata -> CString -> IO Bool++-- | Determine a vorbis comment metadata block can be considered empty.++isVorbisCommentEmpty :: Metadata -> IO Bool+isVorbisCommentEmpty = c_is_vorbis_comment_empty++foreign import ccall unsafe "FLAC__metadata_is_vorbis_comment_empty"+  c_is_vorbis_comment_empty :: Metadata -> IO Bool++----------------------------------------------------------------------------+-- CUE sheet++-- | Get CUE sheet from 'Metadata' block assuming that it's a+-- 'CueSheetBlock'.++getCueSheetData :: Metadata -> IO CueSheetData+getCueSheetData block = do+  cueCatalog <- c_get_cue_sheet_mcn     block >>= B.packCString+  cueLeadIn  <- c_get_cue_sheet_lead_in block+  cueIsCd    <- c_get_cue_sheet_is_cd   block+  numTracks  <- c_get_cue_sheet_num_tracks block+  (cueTracks, cueLeadOutTrack) <-+    case numTracks of+      0 ->+        -- NOTE Should probably never happen unless FLAC file is invalid with+        -- respect to the spec.+        throwM (MetaInvalidCueSheet "Cannot read CUE sheet without tracks")+      1 -> ([],) <$> getCueSheetTrack block 0+      _ -> do+        ts <- mapM (getCueSheetTrack block) [0..numTracks - 2]+        t' <- getCueSheetTrack block (numTracks - 1)+        return (ts,t')+  return CueSheetData {..}++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_mcn"+  c_get_cue_sheet_mcn :: Metadata -> IO CString++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_lead_in"+  c_get_cue_sheet_lead_in :: Metadata -> IO Word64++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_is_cd"+  c_get_cue_sheet_is_cd :: Metadata -> IO Bool++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_num_tracks"+  c_get_cue_sheet_num_tracks :: Metadata -> IO Word8++-- | Peek a single 'CueSheetTrack' at given index.++getCueSheetTrack :: Metadata -> Word8 -> IO CueTrack+getCueSheetTrack block n = do+  cueTrackOffset <- c_get_cue_sheet_track_offset block n+  cueTrackIsrc   <- c_get_cue_sheet_track_isrc   block n >>= B.packCString+  cueTrackAudio  <- c_get_cue_sheet_track_audio  block n+  cueTrackPreEmphasis <- c_get_cue_sheet_track_preemphasis block n+  numIndices     <- c_get_cue_sheet_track_num_indices block n+  (cueTrackPregapIndex, cueTrackIndices) <- if numIndices == 0+    then throwM (MetaInvalidCueSheet "Cannot read CUE track without indices")+    else do+      hasPregap <- c_get_cue_sheet_track_has_pregap_index block n+      let pregapOne :: Num a => a+          pregapOne = if hasPregap then 1 else 0+          range     =+            if numIndices > pregapOne+              then [pregapOne..numIndices - 1]+              else []+      pregapIndex <- if hasPregap+        then Just <$> c_get_cue_sheet_track_index block n 0+        else return Nothing+      trackIndices <- mapM (c_get_cue_sheet_track_index block n) (NE.fromList range)+      return (pregapIndex, trackIndices)+  return CueTrack {..}++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_offset"+  c_get_cue_sheet_track_offset :: Metadata -> Word8 -> IO Word64++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_isrc"+  c_get_cue_sheet_track_isrc :: Metadata -> Word8 -> IO CString++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_audio"+  c_get_cue_sheet_track_audio :: Metadata -> Word8 -> IO Bool++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_preemphasis"+  c_get_cue_sheet_track_preemphasis :: Metadata -> Word8 -> IO Bool++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_num_indices"+  c_get_cue_sheet_track_num_indices :: Metadata -> Word8 -> IO Word8++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_has_pregap_index"+  c_get_cue_sheet_track_has_pregap_index :: Metadata -> Word8 -> IO Bool++foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_index"+  c_get_cue_sheet_track_index :: Metadata -> Word8 -> Word8 -> IO Word64++-- | Set 'CueSheetData' in given 'Metadata' block of type 'CueSheetBlock'.++setCueSheetData :: Metadata -> CueSheetData -> IO Bool+setCueSheetData block CueSheetData {..} = do+  B.useAsCStringLen cueCatalog $ \(mcnPtr, mcnSize) ->+    c_set_cue_sheet_mcn block mcnPtr (fromIntegral mcnSize)+  c_set_cue_sheet_lead_in block cueLeadIn+  c_set_cue_sheet_is_cd   block cueIsCd+  let numTracks = fromIntegral (length cueTracks + 1)+  res <- objectCueSheetResizeTracks block numTracks+  goodOutcome <- if res+    then+      let go ts =+            case uncons ts of+              Nothing ->+                setCueSheetTrack block cueLeadOutTrack (numTracks - 1) 170+              Just ((t,n),ts') -> do+                res' <- setCueSheetTrack block t n (n + 1)+                if res'+                  then go ts'+                  else return False+      in go (zip cueTracks [0..])+    else return False+  when goodOutcome $ do+    res' <- objectCueSheetIsLegal block cueIsCd+    case res' of+      Nothing -> return ()+      Just msg -> throwM (MetaInvalidCueSheet msg)+  return goodOutcome++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_mcn"+  c_set_cue_sheet_mcn :: Metadata -> CString -> CUInt -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_lead_in"+  c_set_cue_sheet_lead_in :: Metadata -> Word64 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_is_cd"+  c_set_cue_sheet_is_cd :: Metadata -> Bool -> IO ()++-- | Poke a 'CueTrack' an specified index.++setCueSheetTrack :: Metadata -> CueTrack -> Word8 -> Word8 -> IO Bool+setCueSheetTrack block CueTrack {..} n n' = do+  c_set_cue_sheet_track_offset block n cueTrackOffset+  c_set_cue_sheet_track_number block n n'+  B.useAsCStringLen cueTrackIsrc $ \(isrcPtr, isrcSize) ->+    c_set_cue_sheet_track_isrc block n isrcPtr (fromIntegral isrcSize)+  c_set_cue_sheet_track_audio block n cueTrackAudio+  c_set_cue_sheet_track_pre_emphasis block n cueTrackPreEmphasis+  let pregapOne :: Num a => a+      pregapOne = if isJust cueTrackPregapIndex then 1 else 0+      numIndices = fromIntegral (NE.length cueTrackIndices + pregapOne)+  goodOutcome <- objectCueSheetTrackResizeIndices block n numIndices+  when goodOutcome $ do+    forM_ cueTrackPregapIndex $ \offset ->+      c_set_cue_sheet_track_index block n 0 0 offset+    let range = zip [pregapOne..] [1..]+    forM_ (NE.zip cueTrackIndices (NE.fromList range)) $ \(offset, (i,i')) ->+      c_set_cue_sheet_track_index block n i i' offset+  return goodOutcome++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_offset"+  c_set_cue_sheet_track_offset :: Metadata -> Word8 -> Word64 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_number"+  c_set_cue_sheet_track_number :: Metadata -> Word8 -> Word8 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_isrc"+  c_set_cue_sheet_track_isrc :: Metadata -> Word8 -> CString -> CUInt -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_audio"+  c_set_cue_sheet_track_audio :: Metadata -> Word8 -> Bool -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_pre_emphasis"+  c_set_cue_sheet_track_pre_emphasis :: Metadata -> Word8 -> Bool -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_cue_sheet_track_index"+  c_set_cue_sheet_track_index :: Metadata -> Word8 -> Word8 -> Word8 -> Word64 -> IO ()++----------------------------------------------------------------------------+-- Picture++-- | Get type of picture assuming that given 'Metadata' block is a+-- 'PictureBolck'.++getPictureType :: Metadata -> IO PictureType+getPictureType = fmap toEnum' . c_get_picture_type++foreign import ccall unsafe "FLAC__metadata_get_picture_type"+  c_get_picture_type :: Metadata -> IO CUInt++-- | Get picture data from given 'Metadata' block.++getPictureData :: Metadata -> IO PictureData+getPictureData block = do+  pictureMimeType    <- c_get_picture_mime_type   block >>= peekCStringText+  pictureDescription <- c_get_picture_description block >>= peekCStringText+  pictureWidth       <- c_get_picture_width       block+  pictureHeight      <- c_get_picture_height      block+  pictureDepth       <- c_get_picture_depth       block+  pictureColors      <- c_get_picture_colors      block+  pictureData        <- alloca $ \dataSizePtr -> do+    dataPtr  <- c_get_picture_data block dataSizePtr+    dataSize <- fromIntegral <$> peek dataSizePtr+    B.packCStringLen (dataPtr, dataSize)+  return PictureData {..}++foreign import ccall unsafe "FLAC__metadata_get_picture_mime_type"+  c_get_picture_mime_type :: Metadata -> IO CString++foreign import ccall unsafe "FLAC__metadata_get_picture_description"+  c_get_picture_description :: Metadata -> IO CString++foreign import ccall unsafe "FLAC__metadata_get_picture_width"+  c_get_picture_width :: Metadata -> IO Word32++foreign import ccall unsafe "FLAC__metadata_get_picture_height"+  c_get_picture_height :: Metadata -> IO Word32++foreign import ccall unsafe "FLAC__metadata_get_picture_depth"+  c_get_picture_depth :: Metadata -> IO Word32++foreign import ccall unsafe "FLAC__metadata_get_picture_colors"+  c_get_picture_colors :: Metadata -> IO Word32++foreign import ccall unsafe "FLAC__metadata_get_picture_data"+  c_get_picture_data :: Metadata -> Ptr Word32 -> IO CString++-- | Set 'PictureType' to given 'Metadata' block that should be a+-- 'PictureBlock'.++setPictureType :: Metadata -> PictureType -> IO ()+setPictureType block pictureType =+  c_set_picture_type block (fromEnum' pictureType)++foreign import ccall unsafe "FLAC__metadata_set_picture_type"+  c_set_picture_type :: Metadata -> CUInt -> IO ()++-- | Set 'PictureData' in given 'Metadata' block of type 'PictureBlock'.++setPictureData :: Metadata -> PictureData -> IO Bool+setPictureData block PictureData {..} = do+  c_set_picture_width  block pictureWidth+  c_set_picture_height block pictureHeight+  c_set_picture_depth  block pictureDepth+  c_set_picture_colors block pictureColors+  goodOutcome <- shortcutFalse+    [ objectPictureSetMimeType    block pictureMimeType+    , objectPictureSetDescription block pictureDescription+    , objectPictureSetData        block pictureData ]+  when goodOutcome $ do+     res <- objectPictureIsLegal block+     case res of+       Nothing  -> return ()+       Just msg -> throwM (MetaInvalidPicture msg)+  return goodOutcome++foreign import ccall unsafe "FLAC__metadata_set_picture_width"+  c_set_picture_width :: Metadata -> Word32 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_picture_height"+  c_set_picture_height :: Metadata -> Word32 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_picture_depth"+  c_set_picture_depth :: Metadata -> Word32 -> IO ()++foreign import ccall unsafe "FLAC__metadata_set_picture_colors"+  c_set_picture_colors :: Metadata -> Word32 -> IO ()++-- | Execute a collection of actions that return 'False' on failure. As soon+-- as failure is reported, stop the execution and return 'False'. Return+-- 'True' in case of success.++shortcutFalse :: [IO Bool] -> IO Bool+shortcutFalse []     = return True+shortcutFalse (m:ms) = m >>= bool (return False) (shortcutFalse ms)
+ Codec/Audio/FLAC/Metadata/Internal/Object.hs view
@@ -0,0 +1,146 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata.Internal.Object+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Wrappers for functions to work with metadata objects, see:+--+-- <https://xiph.org/flac/api/group__flac__metadata__object.html>.++{-# LANGUAGE ForeignFunctionInterface #-}++module Codec.Audio.FLAC.Metadata.Internal.Object+  ( objectNew+  , objectDelete+  , objectSeektableResizePoints+  , objectSeektableIsLegal+  , objectCueSheetResizeTracks+  , objectCueSheetTrackResizeIndices+  , objectCueSheetIsLegal+  , objectPictureSetMimeType+  , objectPictureSetDescription+  , objectPictureSetData+  , objectPictureIsLegal )+where++import Codec.Audio.FLAC.Metadata.Internal.Types+import Codec.Audio.FLAC.Util+import Data.ByteString (ByteString)+import Data.Text (Text)+import Foreign+import Foreign.C.String+import Foreign.C.Types+import qualified Data.ByteString.Unsafe as B++-- | Create a new metadata object given its type.++objectNew :: MetadataType -> IO (Maybe Metadata)+objectNew = fmap maybePtr . c_object_new . fromEnum'++foreign import ccall unsafe "FLAC__metadata_object_new"+  c_object_new :: CUInt -> IO Metadata++-- | Free a metadata object.++objectDelete :: Metadata -> IO ()+objectDelete = c_object_delete++foreign import ccall unsafe "FLAC__metadata_object_delete"+  c_object_delete :: Metadata -> IO ()++-- | Resize the seekpoint array. In case of trouble return 'False'.++objectSeektableResizePoints :: Metadata -> Word32 -> IO Bool+objectSeektableResizePoints block newSize =+  c_object_seektable_resize_points block (fromIntegral newSize)++foreign import ccall unsafe "FLAC__metadata_object_seektable_resize_points"+  c_object_seektable_resize_points :: Metadata -> CUInt -> IO Bool++-- | Check a seek table to see if it conforms to the FLAC specification.+-- Return 'False' if the seek table is illegal.++objectSeektableIsLegal :: Metadata -> IO Bool+objectSeektableIsLegal = c_object_seektable_is_legal++foreign import ccall unsafe "FLAC__metadata_object_seektable_is_legal"+  c_object_seektable_is_legal :: Metadata -> IO Bool++-- | Resize the track array.++objectCueSheetResizeTracks :: Metadata -> Word8 -> IO Bool+objectCueSheetResizeTracks block n =+  c_object_cuesheet_resize_tracks block (fromIntegral n)++foreign import ccall unsafe "FLAC__metadata_object_cuesheet_resize_tracks"+  c_object_cuesheet_resize_tracks :: Metadata -> CUInt -> IO Bool++-- | Resize a track's index point array.++objectCueSheetTrackResizeIndices :: Metadata -> Word8 -> Word8 -> IO Bool+objectCueSheetTrackResizeIndices block n i =+  c_object_cuesheet_track_resize_indices block (fromIntegral n) (fromIntegral i)++foreign import ccall unsafe "FLAC__metadata_object_cuesheet_track_resize_indices"+  c_object_cuesheet_track_resize_indices :: Metadata -> CUInt -> CUInt -> IO Bool++-- | Check a CUE sheet to see if it conforms to the FLAC specification. If+-- something is wrong, the explanation is return in 'Just', otherwise+-- 'Nothing' is returned.++objectCueSheetIsLegal :: Metadata -> Bool -> IO (Maybe Text)+objectCueSheetIsLegal block checkCdda = alloca $ \cstrPtr -> do+  res <- c_object_cuesheet_is_legal block checkCdda cstrPtr+  if res+    then return Nothing+    else Just <$> (peek cstrPtr >>= peekCStringText)++foreign import ccall unsafe "FLAC__metadata_object_cuesheet_is_legal"+  c_object_cuesheet_is_legal :: Metadata -> Bool -> Ptr CString -> IO Bool++-- | Check a picture and return description of what is wrong, otherwise+-- 'Nothing'.++objectPictureIsLegal :: Metadata -> IO (Maybe Text)+objectPictureIsLegal block = alloca $ \cstrPtr -> do+  res <- c_object_picture_is_legal block cstrPtr+  if res+    then return Nothing+    else Just <$> (peek cstrPtr >>= peekCStringText)++foreign import ccall unsafe "FLAC__metadata_object_picture_is_legal"+  c_object_picture_is_legal :: Metadata -> Ptr CString -> IO Bool++-- | Set the MIME type of a given picture block.++objectPictureSetMimeType :: Metadata -> Text -> IO Bool+objectPictureSetMimeType block mimeType =+  withCStringText mimeType $ \cstr ->+    c_object_picture_set_mime_type block cstr True++foreign import ccall unsafe "FLAC__metadata_object_picture_set_mime_type"+  c_object_picture_set_mime_type :: Metadata -> CString -> Bool -> IO Bool++-- | Set the description of a given picture block.++objectPictureSetDescription :: Metadata -> Text -> IO Bool+objectPictureSetDescription block desc =+  withCStringText desc $ \cstr ->+    c_object_picture_set_description block cstr True++foreign import ccall unsafe "FLAC__metadata_object_picture_set_description"+  c_object_picture_set_description :: Metadata -> CString -> Bool -> IO Bool++-- | Set the picture data of a given picture block.++objectPictureSetData :: Metadata -> ByteString -> IO Bool+objectPictureSetData block data' =+  B.unsafeUseAsCStringLen data' $ \(dataPtr, dataSize) ->+    c_object_picture_set_data block dataPtr (fromIntegral dataSize) True++foreign import ccall unsafe "FLAC__metadata_object_picture_set_data"+  c_object_picture_set_data :: Metadata -> CString -> Word32 -> Bool -> IO Bool
+ Codec/Audio/FLAC/Metadata/Internal/Types.hs view
@@ -0,0 +1,269 @@+-- |+-- Module      :  Codec.Audio.FLAC.Metadata.Internal.Types+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Mostly non-public metadata-specific helper types.++module Codec.Audio.FLAC.Metadata.Internal.Types+  ( MetaChain (..)+  , MetaIterator (..)+  , Metadata (..)+  , MetadataType (..)+  , MetaChainStatus (..)+  , MetaException (..)+  , ApplicationId+  , mkApplicationId+  , unApplicationId+  , SeekPoint (..)+  , CueSheetData (..)+  , CueTrack (..)+  , PictureType (..)+  , PictureData (..) )+where++import Control.Exception (Exception)+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid ((<>))+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Void+import Foreign+import qualified Data.ByteString       as B+import qualified Data.ByteString.Char8 as B8++-- | An opaque newtype wrapper around 'Ptr' 'Void', serves to represent+-- pointer to metadata chain.++newtype MetaChain = MetaChain (Ptr Void)++-- | Same as 'MetaChain', this one for pointer to metadata iterator.++newtype MetaIterator = MetaIterator (Ptr Void)++-- | Same as 'MetaChain', this one for pointer to metadata structure itself.++newtype Metadata = Metadata (Ptr Void)++-- | Enumeration of all known metadata blocks.++data MetadataType+  = StreamInfoBlock    -- ^ Stream info block (general data like sample rate)+  | PaddingBlock       -- ^ Padding block+  | ApplicationBlock   -- ^ Application block+  | SeekTableBlock     -- ^ Seek table block+  | VorbisCommentBlock -- ^ Vorbis comment block, a.k.a. FLAC tags+  | CueSheetBlock      -- ^ Cue sheet block+  | PictureBlock       -- ^ Picture block+  | UndefinedBlock     -- ^ Undefined block+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Enumeration of meta chain statuses.++data MetaChainStatus+  = MetaChainStatusOK+    -- ^ The chain is in the normal OK state.+  | MetaChainStatusIllegalInput+    -- ^ The data passed into a function violated the function's usage+    -- criteria.+  | MetaChainStatusErrorOpeningFile+    -- ^ The chain could not open the target file.+  | MetaChainStatusNotFlacFile+    -- ^ The chain could not find the FLAC signature at the start of the+    -- file.+  | MetaChainStatusNotWritable+    -- ^ The chain tried to write to a file that was not writable.+  | MetaChainStatusBadMetadata+    -- ^ The chain encountered input that does not conform to the FLAC+    -- metadata specification.+  | MetaChainStatusReadError+    -- ^ The chain encountered an error while reading the FLAC file.+  | MetaChainStatusSeekError+    -- ^ The chain encountered an error while seeking in the FLAC file.+  | MetaChainStatusWriteError+    -- ^ The chain encountered an error while writing the FLAC file.+  | MetaChainStatusRenameError+    -- ^ The chain encountered an error renaming the FLAC file.+  | MetaChainStatusUnlinkError+    -- ^ The chain encountered an error removing the temporary file.+  | MetaChainStatusMemoryAllocationError+    -- ^ Memory allocation failed.+  | MetaChainStatusInternalError+    -- ^ The caller violated an assertion or an unexpected error occurred.+  | MetaChainStatusInvalidCallbacks+    -- ^ One or more of the required callbacks was NULL.+  | MetaChainStatusReadWriteMismatch+    -- ^ This error occurs when read and write methods do not match (i.e.+    -- when if you read with callbacks, you should also use function that+    -- writes with callbacks).+  | MetaChainStatusWrongWriteCall+    -- ^ Should not ever happen when you use this binding.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Exception that is thrown when manipulation of FLAC metadata fails for+-- some reason.++data MetaException+  = MetaGeneralProblem MetaChainStatus+    -- ^ General failure, see the attached 'MetaChainStatus'.+  | MetaInvalidSeekTable+    -- ^ Invalid seek table was passed to be written.+  | MetaInvalidCueSheet Text+    -- ^ Invalid CUE sheet was passed to be written. The reason why the data+    -- was invalid is attached.+  | MetaInvalidPicture Text+    -- ^ Invalid picture data was passed to be written. The reason why the+    -- data was invalid is attached.+  deriving (Eq, Show, Read)++instance Exception MetaException++-- | A normalizing wrapper around 'ByteString' that makes sure that the+-- 'ByteString' inside is a valid FLAC application name. You can create+-- values of this type using Haskell string literals with+-- @OverloadedStrings@ or with 'mkApplicationId'. Extract the inner+-- 'ByteString' with 'unApplicationId'.++newtype ApplicationId = ApplicationId ByteString+  deriving (Eq, Ord)++instance Show ApplicationId where+  show (ApplicationId appId) = show appId++instance IsString ApplicationId where+  fromString = mkApplicationId . B8.pack++-- | Application id must be four bytes long. If it's too short, null bytes+-- will be appended to it to make it four bytes long. If it's too long, it+-- will be truncated.++mkApplicationId :: ByteString -> ApplicationId+mkApplicationId appId = ApplicationId $+  B.take 4 (appId <> B.replicate 4 0x00)++-- | Get 'ByteString' from 'ApplicationId'.++unApplicationId :: ApplicationId -> ByteString+unApplicationId (ApplicationId appId) = appId++-- | The datatype represents a single point in a seek table metadata block.++data SeekPoint = SeekPoint+  { seekPointSampleNumber :: !Word64+    -- ^ The sample number of the target frame+  , seekPointStreamOffset :: !Word64+    -- ^ The offset in bytes of the target frame with respect to beginning+    -- of the first frame+  , seekPointFrameSamples :: !Word32+    -- ^ The number of samples in the target frame+  } deriving (Eq, Ord, Show, Read)++-- | The data type represents CUE sheet as stored in FLAC metadata. This+-- differs from traditional CUE sheets stored in “.cue” files (see+-- <https://hackage.haskell.org/package/cue-sheet> to work with those).++data CueSheetData = CueSheetData+  { cueCatalog :: !ByteString+    -- ^ Media catalog number, in ASCII printable characters 0x20-0x7e. In+    -- general, the media catalog number may be 0 to 128 bytes long; any+    -- unused characters will be right-padded with NUL characters. For+    -- CD-DA, this is a thirteen digit number.+  , cueLeadIn :: !Word64+    -- ^ The number of lead-in samples. This field has meaning only for+    -- CD-DA CUE sheets; for other uses it should be 0. For CD-DA, the+    -- lead-in is the TRACK 00 area where the table of contents is stored;+    -- more precisely, it is the number of samples from the first sample of+    -- the media to the first sample of the first index point of the first+    -- track. According to the Red Book, the lead-in must be silence and CD+    -- grabbing software does not usually store it; additionally, the+    -- lead-in must be at least two seconds but may be longer. For these+    -- reasons the lead-in length is stored here so that the absolute+    -- position of the first track can be computed. Note that the lead-in+    -- stored here is the number of samples up to the first index point of+    -- the first track, not necessarily to INDEX 01 of the first track; even+    -- the first track may have INDEX 00 data.+  , cueIsCd :: !Bool+    -- ^ 'True' if CUE sheet corresponds to a Compact Disc, else 'False'.+  , cueTracks :: ![CueTrack]+    -- ^ Collection of actual tracks in the CUE sheet, see 'CueTrack'.+  , cueLeadOutTrack :: !CueTrack+    -- ^ The obligatory lead-out track, will be written with index 170.+  } deriving (Eq, Ord, Show, Read)++-- | Data type representing a single track is CUE sheet.++data CueTrack = CueTrack+  { cueTrackOffset :: !Word64+    -- ^ Track offset in samples, relative to the beginning of the FLAC+    -- audio stream. It is the offset to the first index point of the track.+    -- (Note how this differs from CD-DA, where the track's offset in the+    -- TOC is that of the track's INDEX 01 even if there is an INDEX 00.)+    -- For CD-DA, the offset must be evenly divisible by 588 samples (588+    -- samples = 44100 samples\/sec * 1\/75th of a sec).+  , cueTrackIsrc :: !ByteString+    -- ^ Track ISRC, empty if not present. This is a 12-digit alphanumeric+    -- code, the @cue-sheet@ package has corresponding type with smart+    -- constructor and validation, but for now we don't want to depend on+    -- that package.+  , cueTrackAudio :: !Bool+    -- ^ 'True' for audio tracks, 'False' for non-audio tracks.+  , cueTrackPreEmphasis :: !Bool+    -- ^ 'False' for no pre-emphasis, 'True' for pre-emphasis.+  , cueTrackPregapIndex :: !(Maybe Word64)+    -- ^ INDEX 00 (pregap) offset, see 'cueTrackIndices' for more info about+    -- indices.+  , cueTrackIndices :: !(NonEmpty Word64)+    -- ^ Track's index points. Offset in samples, relative to the track+    -- offset, of the index point. For CD-DA, the offset must be evenly+    -- divisible by 588 samples (588 samples = 44100 samples\/sec * 1\/75th+    -- of a sec). Note that the offset is from the beginning of the track,+    -- not the beginning of the audio data.+  } deriving (Eq, Ord, Show, Read)++-- | Type of picture FLAC metadata can contain. There may be several+-- metadata blocks containing pictures of different “types”.++data PictureType+  = PictureOther             -- ^ Other+  | PictureFileIconStandard  -- ^ 32×32 pixels file icon (PNG only)+  | PictureFileIcon          -- ^ Other file icon+  | PictureFrontCover        -- ^ Cover (front)+  | PictureBackCover         -- ^ Cover (back)+  | PictureLeafletPage       -- ^ Leaflet page+  | PictureMedia             -- ^ Media (e.g. label side of CD)+  | PictureLeadArtist        -- ^ Lead artist\/lead performer\/soloist+  | PictureArtist            -- ^ Artist\/performer+  | PictureConductor         -- ^ Conductor+  | PictureBand              -- ^ Band\/orchestra+  | PictureComposer          -- ^ Composer+  | PictureLyricist          -- ^ Lyricist\/text writer+  | PictureRecordingLocation -- ^ Recording location+  | PictureDuringRecording   -- ^ During recording+  | PictureDuringPerformance -- ^ During performance+  | PictureVideoScreenCapture -- ^ Movie\/video screen capture+  | PictureFish              -- ^ A bright coloured fish+  | PictureIllustration      -- ^ Illustration+  | PictureBandLogotype      -- ^ Band\/artist logotype+  | PicturePublisherLogotype -- ^ Publisher\/studio logotype+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Representation of picture contained in a FLAC metadata block.++data PictureData = PictureData+  { pictureMimeType    :: !Text+    -- ^ The picture's MIME data. For best compatibility with players, use+    -- picture data of MIME type @image\/jpeg@ or @image\/png@.+  , pictureDescription :: !Text   -- ^ Picture's description.+  , pictureWidth       :: !Word32 -- ^ Picture's width in pixels.+  , pictureHeight      :: !Word32 -- ^ Picture's height in pixels.+  , pictureDepth       :: !Word32 -- ^ Picture's color depth in bits-per-pixel.+  , pictureColors      :: !Word32+    -- ^ For indexed palettes (like GIF), picture's number of colors (the+    -- number of palette entries), or 0 for non-indexed (i.e. 2 ^ depth).+  , pictureData        :: !ByteString -- ^ Binary picture data.+  } deriving (Eq, Ord, Show, Read)
+ Codec/Audio/FLAC/StreamDecoder.hs view
@@ -0,0 +1,148 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamDecoder+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- The module contains a Haskell interface to FLAC stream decoder.+--+-- === How to use this module+--+-- Just call the 'decodeFlac' function with 'DecoderSettings', input and+-- output file names. The 'decodeFlac' function can produce vanilla WAVE and+-- RF64.+--+-- === Low-level details+--+-- The implementation uses the reference implementation of FLAC — libFLAC (C+-- library) under the hood. This means you'll need at least version 1.3.0 of+-- libFLAC (released 26 May 2013) installed for the binding to work.+--+-- The binding works with minimal overhead compared to pure C+-- implementation. Decoding speed is equal to that of @flac@ command line+-- tool. Memory consumption is minimal and remains constant regardless of+-- size of file to decode.++{-# LANGUAGE RecordWildCards #-}++module Codec.Audio.FLAC.StreamDecoder+  ( DecoderSettings (..)+  , DecoderException (..)+  , DecoderInitStatus (..)+  , DecoderState (..)+  , decodeFlac )+where++import Codec.Audio.FLAC.Metadata+import Codec.Audio.FLAC.StreamDecoder.Internal+import Codec.Audio.FLAC.StreamDecoder.Internal.Helpers+import Codec.Audio.FLAC.StreamDecoder.Internal.Types+import Codec.Audio.FLAC.Util+import Codec.Audio.Wave+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bool (bool)+import Data.Default.Class+import Data.Function+import Data.IORef+import Foreign+import System.Directory+import System.IO++-- | Parameters of stream decoder.++data DecoderSettings = DecoderSettings+  { decoderMd5Checking :: !Bool+    -- ^ If 'True', the decoder will compute the MD5 signature of the+    -- unencoded audio data while decoding and compare it to the signature+    -- from the STREAMINFO block. Default value: 'False'.+  , decoderWaveFormat :: !WaveFormat+    -- ^ This specifies WAVE format in which to save the decoded file. You+    -- can choose between 'WaveVanilla' and 'WaveRF64'; choose the latter if+    -- uncompressed file is expected to be longer than 4 Gb. Default value:+    -- 'WaveVanilla'.+  } deriving (Show, Read, Eq, Ord)++instance Default DecoderSettings where+  def = DecoderSettings+    { decoderMd5Checking = False+    , decoderWaveFormat  = WaveVanilla }++-- | Decode a FLAC file to WAVE.+--+-- 'DecoderException' is thrown when underlying FLAC decoder reports a+-- problem.++decodeFlac :: MonadIO m+  => DecoderSettings   -- ^ Decoder settings+  -> FilePath          -- ^ File to decode+  -> FilePath          -- ^ Where to save the resulting WAVE file+  -> m ()+decodeFlac DecoderSettings {..} ipath' opath' = liftIO . withDecoder $ \d -> do+  ipath <- makeAbsolute ipath'+  opath <- makeAbsolute opath'+  liftInit (decoderSetMd5Checking d decoderMd5Checking)+  (maxBlockSize, wave) <- runFlacMeta def ipath $ do+    let waveFileFormat   = decoderWaveFormat+        waveDataOffset   = 0+        waveDataSize     = 0+        waveOtherChunks  = []+    waveSampleRate <- retrieve SampleRate+    waveSampleFormat <- SampleFormatPcmInt . fromIntegral+      <$> retrieve BitsPerSample+    waveChannelMask <- retrieve ChannelMask+    waveSamplesTotal <- retrieve TotalSamples+    maxBlockSize <- fromIntegral <$> retrieve MaxBlockSize+    return (maxBlockSize, Wave {..})+  let bufferSize = maxBlockSize * fromIntegral (waveBlockAlign wave) + 1+  withTempFile' opath $ \otemp ->+    bracket (mallocBytes bufferSize) free $ \buffer -> do+      initStatus <- decoderInitHelper d ipath buffer+      case initStatus of+        DecoderInitStatusOK -> return ()+        status -> throwIO (DecoderInitFailed status)+      liftBool d (decoderProcessUntilEndOfMetadata d)+      processedRef <- newIORef (0 :: Word64)+      writeWaveFile otemp wave $ \h -> fix $ \nextOne -> do+        processed <- readIORef processedRef+        unless (processed == waveSamplesTotal wave) $ do+          liftBool d (decoderProcessSingle d)+          frameSize <- fromIntegral <$> decoderGetBlockSize d+          let toGrab = frameSize * fromIntegral (waveBlockAlign wave)+          -- FIXME This method relies on the fact that host architecture is+          -- little-endian. It won't work on big-endian architectures. Right+          -- now it's fine with me, but you can open a PR to add big-endian+          -- support.+          hPutBuf h buffer toGrab+          modifyIORef' processedRef (+ fromIntegral frameSize)+          nextOne+      liftBool d (decoderFinish d)+      renameFile otemp opath++----------------------------------------------------------------------------+-- Helpers++-- | Execute an initializing action that returns 'False' on failure and take+-- care of error reporting. In case of trouble, @'DecoderInitFailed'+-- 'DecoderInitStatusAlreadyInitialized'@ is thrown.++liftInit :: IO Bool -> IO ()+liftInit m = liftIO m >>= bool t (return ())+  where+    t = throwIO (DecoderInitFailed DecoderInitStatusAlreadyInitialized)++-- | Execute an action that returns 'False' on failure into taking care of+-- error reporting. In case of trouble @'EncoderFailed'@ with encoder status+-- attached is thrown.++liftBool :: Decoder -> IO Bool -> IO ()+liftBool encoder m = liftIO m >>= bool (throwState encoder) (return ())++-- | Get 'EncoderState' from given 'Encoder' and throw it immediately.++throwState :: Decoder -> IO a+throwState = decoderGetState >=> throwIO . DecoderFailed
+ Codec/Audio/FLAC/StreamDecoder/Internal.hs view
@@ -0,0 +1,111 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamDecoder.Internal+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Low-level Haskell wrapper around FLAC stream decoder API.++{-# LANGUAGE ForeignFunctionInterface #-}++module Codec.Audio.FLAC.StreamDecoder.Internal+  ( withDecoder+  , decoderSetMd5Checking+  , decoderGetState+  , decoderGetBlockSize+  , decoderProcessSingle+  , decoderProcessUntilEndOfMetadata+  , decoderFinish )+where++import Codec.Audio.FLAC.StreamDecoder.Internal.Types+import Codec.Audio.FLAC.Util+import Control.Monad.Catch+import Data.Word+import Foreign.C.Types++-- | Create and use a 'Decoder'. The decoder is guaranteed to be freed even+-- in case of exception.+--+-- If memory for the encoder cannot be allocated, corresponding+-- 'DecoderException' is raised.++withDecoder :: (Decoder -> IO a) -> IO a+withDecoder f = bracket decoderNew (mapM_ decoderDelete) $ \mdecoder ->+  case mdecoder of+    Nothing -> throwM+      (DecoderFailed DecoderStateMemoryAllocationError)+    Just x -> f x++-- | Create a new stream decoder instance with default settings. In the case+-- of memory allocation problem 'Nothing' is returned.++decoderNew :: IO (Maybe Decoder)+decoderNew = maybePtr <$> c_decoder_new++foreign import ccall unsafe "FLAC__stream_decoder_new"+  c_decoder_new :: IO Decoder++-- | Free a decoder instance.++decoderDelete :: Decoder -> IO ()+decoderDelete = c_decoder_delete++foreign import ccall unsafe "FLAC__stream_decoder_delete"+  c_decoder_delete :: Decoder -> IO ()++-- | Set MD5 signature checking. If 'True' the decoder will compute the MD5+-- signature of the unencoded audio data while decoding and compare it to+-- the signature from the stream info block++decoderSetMd5Checking :: Decoder -> Bool -> IO Bool+decoderSetMd5Checking = c_decoder_set_md5_checking++foreign import ccall unsafe "FLAC__stream_decoder_set_md5_checking"+  c_decoder_set_md5_checking :: Decoder -> Bool -> IO Bool++-- | Get current decoder state.++decoderGetState :: Decoder -> IO DecoderState+decoderGetState = fmap toEnum' . c_decoder_get_state++foreign import ccall unsafe "FLAC__stream_decoder_get_state"+  c_decoder_get_state :: Decoder -> IO CUInt++-- | Get frame size as number of inter-channel samples of last decoded+-- frame.++decoderGetBlockSize :: Decoder -> IO Word32+decoderGetBlockSize = fmap fromIntegral . c_decoder_get_blocksize++foreign import ccall unsafe "FLAC__stream_decoder_get_blocksize"+  c_decoder_get_blocksize :: Decoder -> IO CUInt++-- | Process one audio frame. Return 'False' on failure.++decoderProcessSingle :: Decoder -> IO Bool+decoderProcessSingle = c_decoder_process_single++foreign import ccall unsafe "FLAC__stream_decoder_process_single"+  c_decoder_process_single :: Decoder -> IO Bool++-- | Decode until the end of the metadata. We use this to skip to audio+-- stream.++decoderProcessUntilEndOfMetadata :: Decoder -> IO Bool+decoderProcessUntilEndOfMetadata = c_decoder_process_until_end_of_metadata++foreign import ccall unsafe "FLAC__stream_decoder_process_until_end_of_metadata"+  c_decoder_process_until_end_of_metadata :: Decoder -> IO Bool++-- | Finish the decoding process and release resources (also resets decoder+-- and its settings). Return 'False' in case of trouble.++decoderFinish :: Decoder -> IO Bool+decoderFinish = c_decoder_finish++foreign import ccall unsafe "FLAC__stream_decoder_finish"+  c_decoder_finish :: Decoder -> IO Bool
+ Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs view
@@ -0,0 +1,45 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamDecoder.Internal.Helpers+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Wrappers around helpers written to help work with stream decoder.++module Codec.Audio.FLAC.StreamDecoder.Internal.Helpers+  ( decoderInitHelper )+where++import Codec.Audio.FLAC.StreamDecoder.Internal.Types+import Codec.Audio.FLAC.Util+import Data.Void+import Foreign+import Foreign.C.String+import Foreign.C.Types++-- | Initialize decoder to decode FLAC file and register buffer where+-- decoded audio data will go (which must be big enough). Return+-- 'DecoderInitStatus'.++decoderInitHelper+  :: Decoder           -- ^ 'Decoder' to use+  -> FilePath          -- ^ FLAC file to decode+  -> Ptr Void          -- ^ Buffer where to write decoded audio data+  -> IO DecoderInitStatus+     -- ^ Sample rate, bits per sample, channels+decoderInitHelper decoder ipath buffer =+  withCString ipath $ \ipathPtr ->+    toEnum' <$> c_decoder_init_helper+      decoder          -- stream decoder+      ipathPtr         -- name of FLAC file to decode+      buffer           -- output buffer++foreign import ccall unsafe "FLAC__stream_decoder_init_helper"+  c_decoder_init_helper+    :: Decoder+    -> CString+    -> Ptr Void+    -> IO CUInt
+ Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs view
@@ -0,0 +1,93 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamDecoder.Internal.Types+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Mostly non-public stream decoder-specific helper types.++module Codec.Audio.FLAC.StreamDecoder.Internal.Types+  ( Decoder (..)+  , DecoderInitStatus (..)+  , DecoderState (..)+  , DecoderException (..)+  , ChannelAssignment (..) )+where++import Control.Exception+import Data.Void+import Foreign++-- | An opaque newtype wrapper around 'Ptr' 'Void', serves to represent+-- point to decoder instance.++newtype Decoder = Decoder (Ptr Void)++-- | Status of decoder initialization process.++data DecoderInitStatus+  = DecoderInitStatusOK+    -- ^ Initialization was successful.+  | DecoderInitStatusUnsupportedContainer+    -- ^ The library was not compiled with support for the given container+    -- format.+  | DecoderInitStatusInvalidCallbacks+    -- ^ A required callback was not supplied.+  | DecoderInitStatusMemoryAllocationError+    -- ^ An error occurred allocating memory.+  | DecoderInitStatusErrorOpeningFile+    -- ^ fopen() failed.+  | DecoderInitStatusAlreadyInitialized+    -- ^ Initialization was attempted on already initialized decoder.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Enumeration of decoder states.++data DecoderState+  = DecoderStateSearchForMetadata+    -- ^ The decoder is ready to search for metadata.+  | DecoderStateReadMetadata+    -- ^ The decoder is ready to or is in the process of reading metadata.+  | DecoderStateSearchForFrameSync+    -- ^ The decoder is ready to or is in the process of searching for the+    -- frame sync code.+  | DecoderStateReadFrame+    -- ^ The decoder is ready to or is in the process of reading a frame.+  | DecoderStateEndOfStream+    -- ^ The decoder has reached the end of the stream.+  | DecoderStateOggError+    -- ^ An error occurred in the underlying Ogg layer.+  | DecoderStateSeekError+    -- ^ An error occurred while seeking. The decoder must be flushed or+    -- reset before decoding can continue.+  | DecoderStateAborted+    -- ^ The decoder was aborted by the read callback.+  | DecoderStateMemoryAllocationError+    -- ^ An error occurred allocating memory. The decoder is in an invalid+    -- state and can no longer be used.+  | DecoderStateUnititialized+    -- ^ The decoder is in the uninitialized state.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Exception that is thrown when decoding fails for some reason.++data DecoderException+  = DecoderInitFailed DecoderInitStatus+    -- ^ Decoder initialization failed.+  | DecoderFailed DecoderState+    -- ^ Decoder failed.+  deriving (Eq, Show, Read)++instance Exception DecoderException++-- | An enumeration of the available channel assignments.++data ChannelAssignment+  = ChannelAssignmentIndependent -- ^ Independent channels+  | ChannelAssignmentLeftSide    -- ^ Left+side stereo+  | ChannelAssignmentRightSide   -- ^ Right+side stereo+  | ChannelAssignmentMidSide     -- ^ Mid+side stereo+  deriving (Show, Read, Eq, Ord, Bounded, Enum)
+ Codec/Audio/FLAC/StreamEncoder.hs view
@@ -0,0 +1,216 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamEncoder+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- The module contains a Haskell interface to FLAC stream encoder.+--+-- === How to use this module+--+-- Just call the 'encodeFlac' function with 'EncoderSettings', input and+-- output file names. The 'encodeFlac' function only encodes vanilla WAVE+-- and RF64.+--+-- === Low-level details+--+-- The implementation uses the reference implementation of FLAC — libFLAC (C+-- library) under the hood. This means you'll need at least version 1.3.0 of+-- libFLAC (released 26 May 2013) installed for the binding to work.+--+-- The binding works with minimal overhead compared to pure C+-- implementation. Encoding speed is equal to that of @flac@ command line+-- tool. Memory consumption is minimal and remains constant regardless of+-- size of file to decode.++{-# LANGUAGE RecordWildCards #-}++module Codec.Audio.FLAC.StreamEncoder+  ( EncoderSettings (..)+  , EncoderException (..)+  , EncoderInitStatus (..)+  , EncoderState (..)+  , encodeFlac )+where++import Codec.Audio.FLAC.StreamEncoder.Internal+import Codec.Audio.FLAC.StreamEncoder.Internal.Helpers+import Codec.Audio.FLAC.StreamEncoder.Internal.Types+import Codec.Audio.FLAC.Util+import Codec.Audio.Wave+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bool (bool)+import Data.Default.Class+import Data.List.NonEmpty (NonEmpty (..))+import Data.Word+import System.Directory++-- | Parameters of stream encoder. Note that the 'encoderCompression'+-- parameter influences a number of other parameters on its own as specified+-- here+-- <https://xiph.org/flac/api/group__flac__stream__encoder.html#gae49cf32f5256cb47eecd33779493ac85>.+-- The parameters that it sets automatically are wrapped in 'Maybe's, so you+-- can choose whether to use the value that is set by 'encoderCompression'+-- specifying 'Nothing' (default), or use something specific by passing a+-- value inside 'Just'. Thorough understanding of the FLAC format is+-- necessary to achieve good results, though.++data EncoderSettings = EncoderSettings+  { encoderCompression :: !Word32+    -- ^ Compression level [0..8], default is 5.+  , encoderBlockSize :: !Word32+    -- ^ Block size, default is 0.+  , encoderVerify :: !Bool+    -- ^ Verify result (slower), default is 'False'.+  , encoderDoMidSideStereo :: !(Maybe Bool)+    -- ^ Enable mid-side encoding on stereo input. The number of channels+    -- must be 2 for this to have any effect. Default value: 'Nothing'.+  , encoderLooseMidSideStereo :: !(Maybe Bool)+    -- ^ Set to 'True' to enable adaptive switching between mid-side and+    -- left-right encoding on stereo input. Set to 'False' to use exhaustive+    -- searching. Setting this to 'True' requires 'encoderDoMidSideStereo'+    -- to also be set to 'True' in order to have any effect. Default value:+    -- 'Nothing'.+  , encoderApodization :: !(Maybe (NonEmpty ApodizationFunction))+    -- ^ Sets the apodization function(s) the encoder will use when+    -- windowing audio data for LPC analysis. Up to 32 functions are kept,+    -- the rest are dropped. Import+    -- "Codec.Audio.FLAC.StreamEncoder.Apodization" to bring apodization+    -- functions in scope. Default value: 'Nothing'.+  , encoderMaxLpcOrder :: !(Maybe Word32)+    -- ^ Set maximum LPC order, or 0 to use the fixed predictors. Default+    -- value: 'Nothing'.+  , encoderQlpCoeffPrecision :: !(Maybe Word32)+    -- ^ Set the precision in bits of the quantized linear predictor+    -- coefficients, or 0 to let the encoder select it based on the+    -- blocksize. Default value: 'Nothing'.+  , encoderDoQlpCoeffPrecisionSearch :: !(Maybe Bool)+    -- ^ Set to 'False' to use only the specified quantized linear predictor+    -- coefficient precision, or 'True' to search neighboring precision+    -- values and use the best one. Default value: 'Nothing'.+  , encoderDoExhaustiveModelSearch :: !(Maybe Bool)+    -- ^ Set to 'False' to let the encoder estimate the best model order+    -- based on the residual signal energy, or 'True' to force the encoder+    -- to evaluate all order models and select the best. Default value:+    -- 'Nothing'.+  , encoderResidualPartitionOrders :: !(Maybe (Word32, Word32))+    -- ^ Set the minimum and maximum partition order to search when coding+    -- the residual. The partition order determines the context size in the+    -- residual. The context size will be approximately @blocksize / (2 ^+    -- order)@. Set both min and max values to 0 to force a single context,+    -- whose Rice parameter is based on the residual signal variance.+    -- Otherwise, set a min and max order, and the encoder will search all+    -- orders, using the mean of each context for its Rice parameter, and+    -- use the best. Default: 'Nothing'.+  } deriving (Show, Read, Eq, Ord)++instance Default EncoderSettings where+  def = EncoderSettings+    { encoderCompression               = 5+    , encoderBlockSize                 = 0+    , encoderVerify                    = False+    , encoderDoMidSideStereo           = Nothing+    , encoderLooseMidSideStereo        = Nothing+    , encoderApodization               = Nothing+    , encoderMaxLpcOrder               = Nothing+    , encoderQlpCoeffPrecision         = Nothing+    , encoderDoQlpCoeffPrecisionSearch = Nothing+    , encoderDoExhaustiveModelSearch   = Nothing+    , encoderResidualPartitionOrders   = Nothing }++-- | Encode a WAVE file or RF64 file to native FLAC.+--+-- If the input file is not a valid WAVE file, 'WaveException' will be+-- thrown. 'EncoderException' is thrown when underlying FLAC encoder reports+-- a problem.+--+-- Please note that there are a number of limitations on parameters of input+-- audio stream (imposed by current reference FLAC implementation):+--+--     * Number of channels may be only 1–8 inclusive.+--     * Supported values for bits per sample are 4–24 inclusive.+--     * Acceptable sample rate lies in the range 1–655350 inclusive.++encodeFlac :: MonadIO m+  => EncoderSettings   -- ^ Encoder settings+  -> FilePath          -- ^ File to encode+  -> FilePath          -- ^ Where to save the resulting FLAC file+  -> m ()+encodeFlac EncoderSettings {..} ipath' opath' = liftIO . withEncoder $ \e -> do+  ipath <- makeAbsolute ipath'+  opath <- makeAbsolute opath'+  wave  <- readWaveFile ipath+  case waveSampleFormat wave of+    SampleFormatPcmInt _ -> return ()+    fmt -> throwIO (EncoderInvalidSampleFormat fmt)+  let channels      = fromIntegral (waveChannels wave)+      bitsPerSample = fromIntegral (waveBitsPerSample wave)+      sampleRate    = waveSampleRate wave+      totalSamples  = waveSamplesTotal wave+  liftInit (encoderSetChannels      e channels)+  liftInit (encoderSetBitsPerSample e bitsPerSample)+  liftInit (encoderSetSampleRate    e sampleRate)+  liftInit (encoderSetCompression   e encoderCompression)+  liftInit (encoderSetBlockSize     e encoderBlockSize)+  liftInit (encoderSetVerify        e encoderVerify)+  forM_ encoderDoMidSideStereo+    (liftInit . encoderSetDoMidSideStereo e)+  forM_ encoderLooseMidSideStereo+    (liftInit . encoderSetLooseMidSideStereo e)+  forM_ encoderApodization+    (liftInit . encoderSetApodization e . renderApodizationSpec)+  forM_ encoderMaxLpcOrder+    (liftInit . encoderSetMaxLpcOrder e)+  forM_ encoderQlpCoeffPrecision+    (liftInit . encoderSetQlpCoeffPrecision e)+  forM_ encoderDoQlpCoeffPrecisionSearch+    (liftInit . encoderSetDoQlpCoeffPrecisionSearch e)+  forM_ encoderDoExhaustiveModelSearch+    (liftInit . encoderSetDoExhaustiveModelSearch e)+  forM_ encoderResidualPartitionOrders+    (liftInit . encoderSetMinResidualPartitionOrder e . fst)+  forM_ encoderResidualPartitionOrders+    (liftInit . encoderSetMaxResidualPartitionOrder e . snd)+  -- Set the estimate (which is likely correct!), to avoid rewrite of+  -- STREAMINFO metadata block after encoding.+  liftInit (encoderSetTotalSamplesEstimate e totalSamples)+  withTempFile' opath $ \otemp -> do+    initStatus <- encoderInitFile e otemp+    case initStatus of+      EncoderInitStatusOK -> return ()+      status -> throwIO (EncoderInitFailed status)+    liftBool e $ encoderProcessHelper e+      (fromIntegral $ waveDataOffset wave)+      (waveDataSize wave)+      ipath+    liftBool e (encoderFinish e)+    renameFile otemp opath++----------------------------------------------------------------------------+-- Helpers++-- | Execute an initializing action that returns 'False' on failure and take+-- care of error reporting. In case of trouble, @'EncoderInitFailed'+-- 'EncoderInitStatusAlreadyInitialized'@ is thrown.++liftInit :: IO Bool -> IO ()+liftInit m = liftIO m >>= bool t (return ())+  where+    t = throwIO (EncoderInitFailed EncoderInitStatusAlreadyInitialized)++-- | Execute an action that returns 'False' on failure into taking care of+-- error reporting. In case of trouble @'EncoderFailed'@ with encoder status+-- attached is thrown.++liftBool :: Encoder -> IO Bool -> IO ()+liftBool encoder m = liftIO m >>= bool (throwState encoder) (return ())++-- | Get 'EncoderState' from given 'Encoder' and throw it immediately.++throwState :: Encoder -> IO a+throwState = encoderGetState >=> throwIO . EncoderFailed
+ Codec/Audio/FLAC/StreamEncoder/Apodization.hs view
@@ -0,0 +1,19 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamEncoder.Apodization+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- This module exports the 'ApodizationFunction' data type, which is rarely+-- needed, and thus should not “contaminate” the+-- "Codec.Audio.FLAC.StreamEncoder" module with potentially confilcting+-- names.++module Codec.Audio.FLAC.StreamEncoder.Apodization+  ( ApodizationFunction (..) )+where++import Codec.Audio.FLAC.StreamEncoder.Internal.Types
+ Codec/Audio/FLAC/StreamEncoder/Internal.hs view
@@ -0,0 +1,266 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamEncoder.Internal+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Low-level Haskell wrapper around FLAC stream encoder API, see:+--+-- <https://xiph.org/flac/api/group__flac__stream__encoder.html>++{-# LANGUAGE ForeignFunctionInterface #-}++module Codec.Audio.FLAC.StreamEncoder.Internal+  ( withEncoder+  , encoderSetChannels+  , encoderSetBitsPerSample+  , encoderSetSampleRate+  , encoderSetCompression+  , encoderSetBlockSize+  , encoderSetDoMidSideStereo+  , encoderSetLooseMidSideStereo+  , encoderSetApodization+  , encoderSetMaxLpcOrder+  , encoderSetQlpCoeffPrecision+  , encoderSetDoQlpCoeffPrecisionSearch+  , encoderSetDoExhaustiveModelSearch+  , encoderSetMinResidualPartitionOrder+  , encoderSetMaxResidualPartitionOrder+  , encoderSetTotalSamplesEstimate+  , encoderSetVerify+  , encoderGetState+  , encoderInitFile+  , encoderFinish )+where++import Codec.Audio.FLAC.StreamEncoder.Internal.Types+import Codec.Audio.FLAC.Util+import Control.Monad.Catch+import Data.ByteString (ByteString)+import Data.Void+import Foreign+import Foreign.C.String+import Foreign.C.Types+import qualified Data.ByteString as B++-- | Create and use an 'Encoder'. The encoder is guaranteed to be freed even+-- in case of exception.+--+-- If memory for the encoder cannot be allocated, corresponding+-- 'EncoderException' is raised.++withEncoder :: (Encoder -> IO a) -> IO a+withEncoder f = bracket encoderNew (mapM_ encoderDelete) $ \mencoder ->+  case mencoder of+    Nothing -> throwM+      (EncoderFailed EncoderStateMemoryAllocationError)+    Just x -> f x++-- | Create a new stream encoder instance with default settings. In the case+-- of memory allocation problem 'Nothing' is returned.++encoderNew :: IO (Maybe Encoder)+encoderNew = maybePtr <$> c_encoder_new++foreign import ccall unsafe "FLAC__stream_encoder_new"+  c_encoder_new :: IO Encoder++-- | Free an encoder instance.++encoderDelete :: Encoder -> IO ()+encoderDelete = c_encoder_delete++foreign import ccall unsafe "FLAC__stream_encoder_delete"+  c_encoder_delete :: Encoder -> IO ()++-- | Set the number of channels to be encoded. Return 'False' if encoder is+-- already initialized.++encoderSetChannels :: Encoder -> Word32 -> IO Bool+encoderSetChannels encoder channels =+  c_encoder_set_channels encoder (fromIntegral channels)++foreign import ccall unsafe "FLAC__stream_encoder_set_channels"+  c_encoder_set_channels :: Encoder -> CUInt -> IO Bool++-- | Set the same resolution of the input to be encoded. Return 'False' if+-- encoder is already initialized.++encoderSetBitsPerSample :: Encoder -> Word32 -> IO Bool+encoderSetBitsPerSample encoder bps =+  c_encoder_set_bits_per_sample encoder (fromIntegral bps)++foreign import ccall unsafe "FLAC__stream_encoder_set_bits_per_sample"+  c_encoder_set_bits_per_sample :: Encoder -> CUInt -> IO Bool++-- | Set the sample rate in Hz of the input to be encoded. Return 'False' if+-- encoder is already initialized.++encoderSetSampleRate :: Encoder -> Word32 -> IO Bool+encoderSetSampleRate encoder sampleRate =+  c_encoder_set_sample_rate encoder (fromIntegral sampleRate)++foreign import ccall unsafe "FLAC__stream_encoder_set_sample_rate"+  c_encoder_set_sample_rate :: Encoder -> CUInt -> IO Bool++-- | Set the compression level. The argument can range from 0 (fastest,+-- least compression) to 8 (slowest, most compression). A value higher than+-- 8 will be treated as 8. Return 'False' if encoder is already initialized.++encoderSetCompression :: Encoder -> Word32 -> IO Bool+encoderSetCompression encoder level =+  c_encoder_set_compression_level encoder (fromIntegral level)++foreign import ccall unsafe "FLAC__stream_encoder_set_compression_level"+  c_encoder_set_compression_level :: Encoder -> CUInt -> IO Bool++-- | Set the blocksize to use while encoding.++encoderSetBlockSize :: Encoder -> Word32 -> IO Bool+encoderSetBlockSize encoder blockSize =+  c_encoder_set_blocksize encoder (fromIntegral blockSize)++foreign import ccall unsafe "FLAC__stream_encoder_set_blocksize"+  c_encoder_set_blocksize :: Encoder -> CUInt -> IO Bool++-- | Set to 'True' to enable mid-side encoding on stereo input.++encoderSetDoMidSideStereo :: Encoder -> Bool -> IO Bool+encoderSetDoMidSideStereo = c_encoder_set_do_mid_side_stereo++foreign import ccall unsafe "FLAC__stream_encoder_set_do_mid_side_stereo"+  c_encoder_set_do_mid_side_stereo :: Encoder -> Bool -> IO Bool++-- | Set to 'True' to enable adaptive switching between mid-side and+-- left-right encoding on stereo input. Set to 'False' to use exhaustive+-- searching.++encoderSetLooseMidSideStereo :: Encoder -> Bool -> IO Bool+encoderSetLooseMidSideStereo = c_encoder_set_loose_mid_side_stereo++foreign import ccall unsafe "FLAC__stream_encoder_set_loose_mid_side_stereo"+  c_encoder_set_loose_mid_side_stereo :: Encoder -> Bool -> IO Bool++-- | Set the apodization function(s) the encoder will use when windowing+-- audio data for LPC analysis.++encoderSetApodization :: Encoder -> ByteString -> IO Bool+encoderSetApodization encoder specification =+  B.useAsCString specification (c_encoder_set_apodization encoder)++foreign import ccall unsafe "FLAC__stream_encoder_set_apodization"+  c_encoder_set_apodization :: Encoder -> CString -> IO Bool++-- | Set the maximum LPC order, or 0 to use only the fixed predictors.++encoderSetMaxLpcOrder :: Encoder -> Word32 -> IO Bool+encoderSetMaxLpcOrder encoder value =+  c_encoder_set_max_lpc_order encoder (fromIntegral value)++foreign import ccall unsafe "FLAC__stream_encoder_set_max_lpc_order"+  c_encoder_set_max_lpc_order :: Encoder -> CUInt -> IO Bool++-- | Set the precision in bits, of the quantized linear predictor+-- coefficients, or 0 to let the encoder select it based on the blocksize.++encoderSetQlpCoeffPrecision :: Encoder -> Word32 -> IO Bool+encoderSetQlpCoeffPrecision encoder value =+  c_encoder_set_qlp_coeff_precision encoder (fromIntegral value)++foreign import ccall unsafe "FLAC__stream_encoder_set_qlp_coeff_precision"+  c_encoder_set_qlp_coeff_precision :: Encoder -> CUInt -> IO Bool++-- | Set to 'False' to use only the specified quantized linear predictor+-- coefficient precision, or 'True' to search neighboring precision values+-- and use the best one.++encoderSetDoQlpCoeffPrecisionSearch :: Encoder -> Bool -> IO Bool+encoderSetDoQlpCoeffPrecisionSearch = c_encoder_set_qlp_coeff_prec_search++foreign import ccall unsafe "FLAC__stream_encoder_set_do_qlp_coeff_prec_search"+  c_encoder_set_qlp_coeff_prec_search :: Encoder -> Bool -> IO Bool++-- | Set to 'False' to let the encoder estimate the best model order based+-- on the residual signal energy, or 'True' to force the encoder to evaluate+-- all order models and select the best.++encoderSetDoExhaustiveModelSearch :: Encoder -> Bool -> IO Bool+encoderSetDoExhaustiveModelSearch = c_encoder_set_do_exhaustive_model_search++foreign import ccall unsafe "FLAC__stream_encoder_set_do_exhaustive_model_search"+  c_encoder_set_do_exhaustive_model_search :: Encoder -> Bool -> IO Bool++-- | Set the minimum partition order to search when coding the residual.++encoderSetMinResidualPartitionOrder :: Encoder -> Word32 -> IO Bool+encoderSetMinResidualPartitionOrder encoder value =+  c_encoder_set_min_residual_partition_order encoder (fromIntegral value)++foreign import ccall unsafe "FLAC__stream_encoder_set_min_residual_partition_order"+  c_encoder_set_min_residual_partition_order :: Encoder -> CUInt -> IO Bool++-- | Set the maximum partition order to search when coding the residual.++encoderSetMaxResidualPartitionOrder :: Encoder -> Word32 -> IO Bool+encoderSetMaxResidualPartitionOrder encoder value =+  c_encoder_set_max_residual_partition_order encoder (fromIntegral value)++foreign import ccall unsafe "FLAC__stream_encoder_set_max_residual_partition_order"+  c_encoder_set_max_residual_partition_order :: Encoder -> CUInt -> IO Bool++-- | Set an estimate of the total samples that will be encoded. This is+-- merely an estimate and may be set to 0 if unknown. This value will be+-- written to the STREAMINFO block before encoding, and can remove the need+-- for the caller to rewrite the value later if the value is known before+-- encoding.++encoderSetTotalSamplesEstimate :: Encoder -> Word64 -> IO Bool+encoderSetTotalSamplesEstimate = c_encoder_set_total_samples_estimate++foreign import ccall unsafe "FLAC__stream_encoder_set_total_samples_estimate"+  c_encoder_set_total_samples_estimate :: Encoder -> Word64 -> IO Bool++-- | Set the “verify” flag. If true, the encoder will verify it's own+-- encoded output by feeding it through an internal decoder and comparing+-- the original signal against the decoded signal. If a mismatch occurs, the+-- process call will return false. Note that this will slow the encoding+-- process by the extra time required for decoding and comparison.++encoderSetVerify :: Encoder -> Bool -> IO Bool+encoderSetVerify = c_encoder_set_verify++foreign import ccall unsafe "FLAC__stream_encoder_set_verify"+  c_encoder_set_verify :: Encoder -> Bool -> IO Bool++-- | Get current encoder state.++encoderGetState :: Encoder -> IO EncoderState+encoderGetState = fmap toEnum' . c_encoder_get_state++foreign import ccall unsafe "FLAC__stream_encoder_get_state"+  c_encoder_get_state :: Encoder -> IO CUInt++-- | Initialize the encoder instance to encode native FLAC files.++encoderInitFile+  :: Encoder           -- ^ Uninitialized encoder instance+  -> FilePath          -- ^ Name of file to encode to+  -> IO EncoderInitStatus+encoderInitFile encoder path =+  withCString path $ \cstr ->+    toEnum' <$> c_encoder_init_file encoder cstr nullPtr nullPtr++foreign import ccall unsafe "FLAC__stream_encoder_init_file"+  c_encoder_init_file :: Encoder -> CString -> Ptr Void -> Ptr Void -> IO CUInt++-- | Finish the encoding process and release resources (also resets encoder+-- and its settings). Return 'False' in case of trouble.++encoderFinish :: Encoder -> IO Bool+encoderFinish = c_encoder_finish++foreign import ccall unsafe "FLAC__stream_encoder_finish"+  c_encoder_finish :: Encoder -> IO Bool
+ Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs view
@@ -0,0 +1,92 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamEncoder.Internal.Helpers+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Wrappers around helpers written to help work with stream encoder.++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}++module Codec.Audio.FLAC.StreamEncoder.Internal.Helpers+  ( encoderProcessHelper+  , renderApodizationSpec )+where++import Codec.Audio.FLAC.StreamEncoder.Internal.Types+import Data.ByteString (ByteString)+import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid ((<>))+import Data.Word (Word64)+import Foreign.C.String+import Numeric.Natural+import qualified Data.ByteString.Builder as BU+import qualified Data.ByteString.Lazy    as BL+import qualified Data.List.NonEmpty      as NE++-- | Encode given input file, return 'False' in case of failure.++encoderProcessHelper+  :: Encoder           -- ^ 'Encoder' to use+  -> Word64            -- ^ Offset of data chunk+  -> Word64            -- ^ Size of data chunk+  -> FilePath          -- ^ Location of input file (normalized)+  -> IO Bool           -- ^ 'False' in case of trouble+encoderProcessHelper encoder dataOffset dataSize ipath =+  withCString ipath $ \ipathPtr ->+    c_encoder_process_helper+      encoder          -- stream encoder+      dataOffset       -- offset of data chunk+      dataSize         -- size of data chunk+      ipathPtr         -- path to input file++foreign import ccall unsafe "FLAC__stream_encoder_process_helper"+  c_encoder_process_helper :: Encoder -> Word64 -> Word64 -> CString -> IO Bool++-- | Render apodization functions specification as per description here:+-- <https://xiph.org/flac/api/group__flac__stream__encoder.html#ga6598f09ac782a1f2a5743ddf247c81c8>.++renderApodizationSpec :: NonEmpty ApodizationFunction -> ByteString+renderApodizationSpec =+  BL.toStrict         .+  BU.toLazyByteString .+  mconcat             .+  intersperse ";"     .+  NE.toList           .+  fmap f+  where+    f :: ApodizationFunction -> BU.Builder+    f Bartlett                = "bartlett"+    f BartlettHann            = "bartlett_hann"+    f Blackman                = "blackman"+    f BlackmanHarris4Term92Db = "blackman_harris_4term_92db"+    f Connes                  = "connes"+    f Flattop                 = "flattop"+    f (Gauss stddev)          = "gauss(" <> BU.doubleDec stddev <> ")"+    f Hamming                 = "hamming"+    f Hann                    = "hann"+    f KaiserBessel            = "kaiser_bessel"+    f Nuttall                 = "nuttall"+    f Rectangle               = "rectangle"+    f Triangle                = "triangle"+    f (Tukey p)               = "tukey(" <> BU.doubleDec p <> ")"+    f (PartialTukey n Nothing) =+      "partial_tukey(" <> natDec n <> ")"+    f (PartialTukey n (Just (ov, Nothing))) =+      "partial_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> ")"+    f (PartialTukey n (Just (ov, Just p))) =+      "partial_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> "/" <> BU.doubleDec p <> ")"+    f (PunchoutTukey n Nothing) =+      "punchout_tukey(" <> natDec n <> ")"+    f (PunchoutTukey n (Just (ov, Nothing))) =+      "punchout_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> ")"+    f (PunchoutTukey n (Just (ov, Just p))) =+      "punchout_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> "/" <> BU.doubleDec p <> ")"+    f Welch                   = "welch"+    natDec :: Natural -> BU.Builder+    natDec = BU.integerDec . fromIntegral
+ Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs view
@@ -0,0 +1,143 @@+-- |+-- Module      :  Codec.Audio.FLAC.StreamEncoder.Internal.Types+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Mostly non-public stream encoder-specific helper types.++module Codec.Audio.FLAC.StreamEncoder.Internal.Types+  ( Encoder (..)+  , EncoderInitStatus (..)+  , EncoderState (..)+  , EncoderException (..)+  , ApodizationFunction (..) )+where++import Codec.Audio.Wave (SampleFormat)+import Control.Exception+import Data.Void+import Foreign+import Numeric.Natural++-- | An opaque newtype wrapper around 'Ptr' 'Void', serves to represent+-- pointer to encoder instance.++newtype Encoder = Encoder (Ptr Void)++-- | Status of encoder initialization process.++data EncoderInitStatus+  = EncoderInitStatusOK+    -- ^ Initialization was successful.+  | EncoderInitStatusEncoderError+    -- ^ General failure to set up encoder.+  | EncoderInitStatusUnsupportedCointainer+    -- ^ The library was not compiled with support for the given container+    -- format.+  | EncoderInitStatusInvalidCallbacks+    -- ^ A required callback was not supplied.+  | EncoderInitStatusInvalidNumberOfChannels+    -- ^ The encoder has an invalid setting for number of channels.+  | EncoderInitStatusInvalidBitsPerSample+    -- ^ The encoder has an invalid setting for bits-per-sample. FLAC+    -- supports 4-32 bps but the reference encoder currently supports only+    -- up to 24 bps.+  | EncoderInitStatusInvalidSampleRate+    -- ^ The encoder has an invalid setting for the sample rate.+  | EncoderInitStatusInvalidBlockSize+    -- ^ The encoder has an invalid setting for the block size.+  | EncoderInitStatusInvalidMaxLpcOrder+    -- ^ The encoder has an invalid setting for the maximum LPC order.+  | EncoderInitStatusInvalidQlpCoeffPrecision+    -- ^ The encoder has an invalid setting for the precision of the+    -- quantized linear predictor coefficients.+  | EncoderInitStatusBlockSizeTooSmallForLpcOrder+    -- ^ The specified block size is less than the maximum LPC order.+  | EncoderInitStatusNotStreamable+    -- ^ The encoder is bound to the Subset but other settings violate it.+  | EncoderInitStatusInvalidMetadata+    -- ^ The metadata input to the encoder is invalid (should never happen+    -- with this binding).+  | EncoderInitStatusAlreadyInitialized+    -- ^ Initialization was attempted on already initialized encoder.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Enumeration of encoder states.++data EncoderState+  = EncoderStateOK+    -- ^ The encoder is in the normal OK state and samples can be processed.+  | EncoderStateUninitialized+    -- ^ The encoder is in the uninitialized state.+  | EncoderStateOggError+    -- ^ An error occurred in the underlying Ogg layer.+  | EncoderStateVerifyDecoderError+    -- ^ An error occurred in the underlying verify stream decoder.+  | EncoderStateVerifyMismatchInAudioData+    -- ^ The verify decoder detected a mismatch between the original audio+    -- signal and the decoded audio signal.+  | EncoderStateClientError+    -- ^ One of the callbacks returned a fatal error.+  | EncoderStateIOError+    -- ^ An I\/O error occurred while opening\/reading\/writing a file.+  | EncoderStateFramingError+    -- ^ An error occurred while writing the stream.+  | EncoderStateMemoryAllocationError+    -- ^ Memory allocation failed.+  deriving (Show, Read, Eq, Ord, Bounded, Enum)++-- | Exception that is thrown when encoding fails for some reason.++data EncoderException+  = EncoderInvalidSampleFormat SampleFormat+    -- ^ Input WAVE file had this sample format, which is not supported+    -- (usually happens with floating point samples right now).+  | EncoderInitFailed EncoderInitStatus+    -- ^ Encoder initialization failed.+  | EncoderFailed EncoderState+    -- ^ Encoder failed.+  deriving (Eq, Show, Read)++instance Exception EncoderException++-- | Supported apodization functions.++data ApodizationFunction+  = Bartlett+  | BartlettHann+  | Blackman+  | BlackmanHarris4Term92Db+  | Connes+  | Flattop+  | Gauss Double+    -- ^ The parameter is standard deviation @STDDEV@, @0 < STDDEV <= 0.5@.+  | Hamming+  | Hann+  | KaiserBessel+  | Nuttall+  | Rectangle+  | Triangle+  | Tukey Double+    -- ^ The parameter is the fraction of the window that is tapered @P@,+    -- @0 <= P <= 1@. @P == 0@ corresponds to 'Rectangle' and @P = 1@+    -- corresponds to 'Hann'.+  | PartialTukey Natural (Maybe (Double, Maybe Double))+    -- ^ The parameters are a series of small windows (all treated+    -- separately). The three parameters are @n@, @ov@ and @P@. @n@ is the+    -- number of functions to add, @ov@ is the overlap of the windows. @P@+    -- is the fraction of the window that is tapered, like with a regular+    -- tukey window. The function can be specified with only a number, a+    -- number and an overlap, or a number, an overlap and a @P@. @ov@ should+    -- be smaller than 1 and can be negative.+  | PunchoutTukey Natural (Maybe (Double, Maybe Double))+    -- ^ The parameters are a series of windows that have a hole in them. In+    -- this way, the predictor is constructed with only a part of the block,+    -- which helps in case a block consists of dissimilar parts. All said+    -- about the parameters in the comment for 'PartialTukey' applies here,+    -- with the exception that @ov@ is the overlap in the gaps in this case.+  | Welch+  deriving (Eq, Show, Read, Ord)
+ Codec/Audio/FLAC/Util.hs view
@@ -0,0 +1,86 @@+-- |+-- Module      :  Codec.Audio.FLAC.Util+-- Copyright   :  © 2016–2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Random non-public helpers.++module Codec.Audio.FLAC.Util+  ( maybePtr+  , toEnum'+  , fromEnum'+  , peekCStringText+  , withCStringText+  , withTempFile' )+where++import Control.Exception+import Data.Text (Text)+import Foreign+import Foreign.C.String+import System.Directory+import System.FilePath+import System.IO+import Unsafe.Coerce+import qualified Data.ByteString    as B+import qualified Data.Text          as T+import qualified Data.Text.Encoding as T++-- | Coerce to 'Ptr' and check if it's a null pointer, return 'Nothing' if+-- it is, otherwise return the given pointer unchanged. Needless to say that+-- this thing is unsafe.++maybePtr :: a -> Maybe a+maybePtr a+  | unsafeCoerce a == nullPtr = Nothing+  | otherwise                 = Just a++-- | A version of 'toEnum' that converts from any 'Integral' type.++toEnum' :: (Integral a, Enum b) => a -> b+toEnum' = toEnum . fromIntegral++-- | A version of 'fromEnum' that is polymorphic in return type.++fromEnum' :: (Integral a, Enum b) => b -> a+fromEnum' = fromIntegral . fromEnum++-- | Peek 'CString' and decode it as UTF-8 encoded value.++peekCStringText :: CString -> IO Text+peekCStringText = fmap T.decodeUtf8 . B.packCString++-- | Convert a 'Text' value to null-terminated C string that will be freed+-- automatically. Null bytes are removed from the 'Text' value first.++withCStringText :: Text -> (CString -> IO a) -> IO a+withCStringText text = B.useAsCString bytes+  where bytes = T.encodeUtf8 (T.filter (/= '\0') text)++-- | A custom wrapper for creating temporary files in the same directory as+-- given file. 'Handle' is not opened, you only get 'FilePath' in the+-- callback.++withTempFile' :: FilePath -> (FilePath -> IO a) -> IO a+withTempFile' path = bracketOnError acquire cleanup+  where+    acquire = do+      (path',h) <- openBinaryTempFile dir file+      hClose h+      return path'+    cleanup = ignoringIOErrors . removeFile -- in case exception strikes+              -- before we create the actual file+    dir     = takeDirectory path+    file    = takeFileName  path++-- | Perform specified action ignoring IO exceptions it may throw.++ignoringIOErrors :: IO () -> IO ()+ignoringIOErrors ioe = ioe `catch` handler+  where+    handler :: IOError -> IO ()+    handler = const (return ())
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright © 2016–2017 Mark Karpov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.++* Neither the name Mark Karpov nor the names of contributors may be used to+  endorse or promote products derived from this software without specific+  prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,118 @@+# FLAC for Haskell++[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause)+[![Hackage](https://img.shields.io/hackage/v/flac.svg?style=flat)](https://hackage.haskell.org/package/flac)+[![Stackage Nightly](http://stackage.org/package/flac/badge/nightly)](http://stackage.org/nightly/package/flac)+[![Stackage LTS](http://stackage.org/package/flac/badge/lts)](http://stackage.org/lts/package/flac)+[![Build Status](https://travis-ci.org/mrkkrp/flac.svg?branch=master)](https://travis-ci.org/mrkkrp/flac)+[![Coverage Status](https://coveralls.io/repos/mrkkrp/flac/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/flac?branch=master)++* [Aims of the project](#aims-of-the-project)+* [Motivation](#motivation)+* [Provided functionality](#provided-functionality)+* [Limitations](#limitations)+* [Quick start](#quick-start)+* [Related packages](#related-packages)+* [Contribution](#contribution)+* [License](#license)++This is a complete high-level Haskell binding+to [libFLAC](https://xiph.org/flac/).++## Aims of the project++Here are several ideas the project follows:++* Concentrate only on native FLAC format without messing with other audio+  formats or their flavors. This library is about FLAC only.++* Be a complete interface for FLAC file manipulation in Haskell. “Complete”+  means that everything supported by the reference implementation should be+  supported by this package. This is in the hope to prevent fragmentation+  and proliferation of different libraries to work with FLAC with each of+  them covering only some 80% of functionality the library author needed and+  neglecting other 20%. A lot of effort was put to make the first libFLAC+  binding so good so you don't need another one.++* Be as efficient as the underlying C implementation, avoid adding any sort+  of overhead (memory/speed/or otherwise).++* Provide *idiot-proof* API using type system to kindly guard against bad+  things, but not so much to remain beginner-friendly and simple.++* Make invalid code and data unrepresentable.++## Motivation++FLAC is awesome and Haskell is awesome, surely there should be a way to+achieve an even higher level of awesomeness by coding a safe Haskell API to+the fast libFLAC library.++Seriously though, we+have [`htaglib`](https://hackage.haskell.org/package/htaglib) to work with+audio metadata, but it does not support a lot of FLAC-specific things I'd+love to manipulate. We+have [`hsndfile`](https://hackage.haskell.org/package/hsndfile), but I don't+really want to read FLAC data into a buffer or Haskell `Vector`. How simple+it is (if possible) to decode a FLAC file using that library? How simple it+is to figure out where to begin with such a task? With `flac` it's+`decodeFlac def "myfile.falc" "myfile.wav"` — done, average song in a+fraction of second.++## Provided functionality++Here we go:++* Metadata — full support for reading/writing/deleting of all audio+  parameters, application data, seek tables, vorbis comments of all sorts,+  CUE sheets, and even pictures.++* Stream decoder — simple interface for decoding to vanilla WAVE and RF64+  (support for files larger than 4 Gb).++* Stream encoder — a lot of options to tweak, everything that libFLAC has,+  but you can also use `def` and just encode vanilla WAVE or RF64 file into+  native FLAC. Simple and efficient.++## Limitations++Right now there are three main limitations:++* No Ogg FLAC support, and I do not plan to add it, but I'll accept a PR+  adding support for Ogg FLAC.++* It's not possible to use custom callbacks for printing decoding/encoding+  progress in real-time and stuff like that. Not a big issue IMO, given that+  we get easy and safe API instead.++* Only works on little-endian architectures so far, I'll accept a PR lifting+  this limitation.++## Quick start++The best way to start using `flac` is to take a look+at [the Haddocks](https://hackage.haskell.org/package/flac). Encoding and+decoding is so simple that a baby could handle it, and for metadata there+are examples and a lot of details in the docs. Feel free to ask me question+if you get stuck with something though.++## Related packages++The following packages are designed to be used with `flac`:++* [`flac-picture`](https://hackage.haskell.org/package/flac-picture) — add+  pictures to FLAC metadata easier.++## Contribution++Please kindly direct all issues, bugs, and questions+to+[the GitHub issue tracker for this project](https://github.com/mrkkrp/flac/issues).++Pull requests are also welcome and will be reviewed quickly.++## License++Copyright © 2016–2017 Mark Karpov++Distributed under BSD 3 clause license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ audio-samples/1ch-44100hz-16bit-full-range.wav view

binary file changed (absent → 20044 bytes)

+ audio-samples/1ch-44100hz-16bit-silence.wav view

binary file changed (absent → 20044 bytes)

+ audio-samples/1ch-44100hz-16bit-x.wav view

binary file changed (absent → 5126 bytes)

+ audio-samples/1ch-44100hz-16bit.rf64 view

binary file changed (absent → 5150 bytes)

+ audio-samples/1ch-44100hz-16bit.wav view

binary file changed (absent → 5090 bytes)

+ audio-samples/1ch-44100hz-24bit-full-range.wav view

binary file changed (absent → 30044 bytes)

+ audio-samples/1ch-44100hz-24bit-silence.wav view

binary file changed (absent → 30044 bytes)

+ audio-samples/1ch-44100hz-8bit-full-range.wav view

binary file changed (absent → 10044 bytes)

+ audio-samples/1ch-44100hz-8bit-silence.wav view

binary file changed (absent → 10044 bytes)

+ audio-samples/2ch-11025hz-24bit-x.wav view

binary file changed (absent → 23354 bytes)

+ audio-samples/2ch-11025hz-24bit.rf64 view

binary file changed (absent → 23378 bytes)

+ audio-samples/2ch-11025hz-24bit.wav view

binary file changed (absent → 23318 bytes)

+ audio-samples/2ch-8000hz-8bit-x.wav view

binary file changed (absent → 11456 bytes)

+ audio-samples/2ch-8000hz-8bit.rf64 view

binary file changed (absent → 11480 bytes)

+ audio-samples/2ch-8000hz-8bit.wav view

binary file changed (absent → 11420 bytes)

+ audio-samples/sample.flac view

binary file changed (absent → 11459 bytes)

+ cbits/metadata_level2_helpers.c view
@@ -0,0 +1,412 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#include "metadata_level2_helpers.h"++/* Stream info */++unsigned FLAC__metadata_get_min_blocksize(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.min_blocksize;+}++unsigned FLAC__metadata_get_max_blocksize(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.max_blocksize;+}++unsigned FLAC__metadata_get_min_framesize(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.min_framesize;+}++unsigned FLAC__metadata_get_max_framesize(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.max_framesize;+}++unsigned FLAC__metadata_get_sample_rate(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.sample_rate;+}++unsigned FLAC__metadata_get_channels(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.channels;+}++unsigned FLAC__metadata_get_bits_per_sample(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.bits_per_sample;+}++FLAC__uint64 FLAC__metadata_get_total_samples(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.total_samples;+}++FLAC__byte *FLAC__metadata_get_md5sum(FLAC__StreamMetadata *block)+{+  return block->data.stream_info.md5sum;+}++/* Application */++FLAC__byte *FLAC__metadata_get_application_id(FLAC__StreamMetadata *block)+{+  return block->data.application.id;+}++FLAC__byte *FLAC__metadata_get_application_data+  (FLAC__StreamMetadata *block, unsigned *length)+{+  *length = block->length - 4;+  return block->data.application.data;+}++void FLAC__metadata_set_application_id+  (FLAC__StreamMetadata *block, FLAC__byte *id)+{+  unsigned i;+  for (i = 0; i < 4; i++)+    *(block->data.application.id + i) = *(id + i);+}++FLAC__bool FLAC__metadata_set_application_data+  (FLAC__StreamMetadata *block, FLAC__byte *data, unsigned length)+{+  return FLAC__metadata_object_application_set_data(block, data, length, true);+}++/* Seek table */++unsigned FLAC__metadata_get_seek_points_num(FLAC__StreamMetadata *block)+{+  return block->data.seek_table.num_points;+}++FLAC__StreamMetadata_SeekPoint *FLAC__metadata_get_seek_point+  (FLAC__StreamMetadata *block, unsigned point_num)+{+  return block->data.seek_table.points + point_num;+}++void FLAC__metadata_set_seek_point+  ( FLAC__StreamMetadata *block+  , unsigned point_num+  , FLAC__uint64 sample_number+  , FLAC__uint64 stream_offset+  , unsigned frame_samples )+{+  FLAC__StreamMetadata_SeekPoint sp;+  sp.sample_number = sample_number;+  sp.stream_offset = stream_offset;+  sp.frame_samples = frame_samples;+  FLAC__metadata_object_seektable_set_point(block, point_num, sp);+}++/* Vorbis comment */++FLAC__byte *FLAC__metadata_get_vorbis_vendor+  (FLAC__StreamMetadata *block, FLAC__uint32 *length)+{+  *length = block->data.vorbis_comment.vendor_string.length;+  return block->data.vorbis_comment.vendor_string.entry;+}++FLAC__bool FLAC__metadata_set_vorbis_vendor+  (FLAC__StreamMetadata *block, FLAC__byte *entry, FLAC__uint32 length)+{+  FLAC__StreamMetadata_VorbisComment_Entry e;+  e.length = length;+  e.entry  = entry;+  return FLAC__metadata_object_vorbiscomment_set_vendor_string(block, e, true);+}++FLAC__byte *FLAC__metadata_get_vorbis_comment+  (FLAC__StreamMetadata *block, const char *name, FLAC__uint32 *length)+{+  int i;+  FLAC__StreamMetadata_VorbisComment_Entry *e;+  i = FLAC__metadata_object_vorbiscomment_find_entry_from(block, 0, name);+  if (i == -1)+    {+      return NULL;+    }+  else+    {+      e = block->data.vorbis_comment.comments + i;+      *length = e->length;+      return e->entry;+    }+}++FLAC__bool FLAC__metadata_set_vorbis_comment+  (FLAC__StreamMetadata *block, FLAC__byte *entry, FLAC__uint32 length)+{+  FLAC__StreamMetadata_VorbisComment_Entry e;+  e.length = length;+  e.entry = entry;+  return FLAC__metadata_object_vorbiscomment_replace_comment(block, e, true, true);+}++FLAC__bool FLAC__metadata_delete_vorbis_comment+  (FLAC__StreamMetadata *block, const char *name)+{+  int i;+  i = FLAC__metadata_object_vorbiscomment_find_entry_from(block, 0, name);+  if (i >= 0)+    {+      return FLAC__metadata_object_vorbiscomment_delete_comment(block, i);+    }+  else+    {+      return true;+    }+}++FLAC__bool FLAC__metadata_is_vorbis_comment_empty(FLAC__StreamMetadata *block)+{+  return (block->data.vorbis_comment.vendor_string.length == 0) &&+    (block->data.vorbis_comment.num_comments == 0);+}++/* CUE sheet */++char *FLAC__metadata_get_cue_sheet_mcn(FLAC__StreamMetadata *block)+{+  return (block->data.cue_sheet.media_catalog_number);+}++FLAC__uint64 FLAC__metadata_get_cue_sheet_lead_in(FLAC__StreamMetadata *block)+{+  return (block->data.cue_sheet.lead_in);+}++FLAC__bool FLAC__metadata_get_cue_sheet_is_cd(FLAC__StreamMetadata *block)+{+  return (block->data.cue_sheet.is_cd);+}++FLAC__byte FLAC__metadata_get_cue_sheet_num_tracks(FLAC__StreamMetadata *block)+{+  return (block->data.cue_sheet.num_tracks);+}++FLAC__uint64 FLAC__metadata_get_cue_sheet_track_offset+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return (block->data.cue_sheet.tracks + n)->offset;+}++char *FLAC__metadata_get_cue_sheet_track_isrc+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return (block->data.cue_sheet.tracks + n)->isrc;+}++FLAC__bool FLAC__metadata_get_cue_sheet_track_audio+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return !(block->data.cue_sheet.tracks + n)->type;+}++FLAC__bool FLAC__metadata_get_cue_sheet_track_preemphasis+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return (block->data.cue_sheet.tracks + n)->pre_emphasis;+}++FLAC__byte FLAC__metadata_get_cue_sheet_track_num_indices+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return (block->data.cue_sheet.tracks + n)->num_indices;+}++FLAC__bool FLAC__metadata_get_cue_sheet_track_has_pregap_index+  (FLAC__StreamMetadata *block, FLAC__byte n)+{+  return ((block->data.cue_sheet.tracks + n)->indices + 0)-> number == 0;+}++FLAC__uint64 FLAC__metadata_get_cue_sheet_track_index+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__byte i)+{+  return ((block->data.cue_sheet.tracks + n)->indices + i)->offset;+}++void FLAC__metadata_set_cue_sheet_mcn+  (FLAC__StreamMetadata *block, char *source, unsigned length)+{+  unsigned i;+  char *target = block->data.cue_sheet.media_catalog_number;+  for (i = 0; i < 129; i++)+    {+      if (i < length)+        *(target + i) = *(source + i);+      else+        *(target + i) = 0;+    }+}++void FLAC__metadata_set_cue_sheet_lead_in+  (FLAC__StreamMetadata *block, FLAC__uint64 lead_in)+{+  block->data.cue_sheet.lead_in = lead_in;+}++void FLAC__metadata_set_cue_sheet_is_cd+  (FLAC__StreamMetadata *block, FLAC__bool is_cd)+{+  block->data.cue_sheet.is_cd = is_cd;+}++void FLAC__metadata_set_cue_sheet_track_offset+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__uint64 offset)+{+  (block->data.cue_sheet.tracks + n)->offset = offset;+}++void FLAC__metadata_set_cue_sheet_track_number+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__byte n_)+{+  (block->data.cue_sheet.tracks + n)->number = n_;+}++void FLAC__metadata_set_cue_sheet_track_isrc+  (FLAC__StreamMetadata *block, FLAC__byte n, char *source, unsigned length)+{+  unsigned i;+  char *target = (block->data.cue_sheet.tracks + n)->isrc;+  for (i = 0; i < 13; i++)+    {+      if (i < length)+        *(target + i) = *(source + i);+      else+        *(target + i) = 0;+    }+}++void FLAC__metadata_set_cue_sheet_track_audio+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__bool audio)+{+  (block->data.cue_sheet.tracks + n)->type = !audio;+}++void FLAC__metadata_set_cue_sheet_track_pre_emphasis+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__bool pre_emphasis)+{+  (block->data.cue_sheet.tracks + n)->pre_emphasis = pre_emphasis;+}++void FLAC__metadata_set_cue_sheet_track_index+  (FLAC__StreamMetadata *block, FLAC__byte n, FLAC__byte i, FLAC__byte i_, FLAC__uint64 offset)+{+  ((block->data.cue_sheet.tracks + n)->indices + i)->offset = offset;+  ((block->data.cue_sheet.tracks + n)->indices + i)->number = i_;+}++/* Picture */++FLAC__StreamMetadata_Picture_Type FLAC__metadata_get_picture_type+  (FLAC__StreamMetadata *block)+{+  return block->data.picture.type;+}++char *FLAC__metadata_get_picture_mime_type(FLAC__StreamMetadata *block)+{+  return block->data.picture.mime_type;+}++FLAC__byte *FLAC__metadata_get_picture_description(FLAC__StreamMetadata *block)+{+  return block->data.picture.description;+}++FLAC__uint32 FLAC__metadata_get_picture_width(FLAC__StreamMetadata *block)+{+  return block->data.picture.width;+}++FLAC__uint32 FLAC__metadata_get_picture_height(FLAC__StreamMetadata *block)+{+  return block->data.picture.height;+}++FLAC__uint32 FLAC__metadata_get_picture_depth(FLAC__StreamMetadata *block)+{+  return block->data.picture.depth;+}++FLAC__uint32 FLAC__metadata_get_picture_colors(FLAC__StreamMetadata *block)+{+  return block->data.picture.colors;+}++FLAC__byte *FLAC__metadata_get_picture_data+  (FLAC__StreamMetadata *block, FLAC__uint32 *length)+{+  *length = block->data.picture.data_length;+  return block->data.picture.data;+}++void FLAC__metadata_set_picture_type+  (FLAC__StreamMetadata *block, FLAC__StreamMetadata_Picture_Type picture_type)+{+  block->data.picture.type = picture_type;+}++void FLAC__metadata_set_picture_width+  (FLAC__StreamMetadata *block, FLAC__uint32 width)+{+  block->data.picture.width = width;+}++void FLAC__metadata_set_picture_height+  (FLAC__StreamMetadata *block, FLAC__uint32 height)+{+  block->data.picture.height = height;+}++void FLAC__metadata_set_picture_depth+  (FLAC__StreamMetadata *block, FLAC__uint32 depth)+{+  block->data.picture.depth = depth;+}++void FLAC__metadata_set_picture_colors+  (FLAC__StreamMetadata *block, FLAC__uint32 colors)+{+  block->data.picture.colors = colors;+}
+ cbits/metadata_level2_helpers.h view
@@ -0,0 +1,117 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#ifndef FLAC__METADATA_LEVEL2_HELPERS_H+#define FLAC__METADATA_LEVEL2_HELPERS_H++#include <FLAC/format.h>+#include <FLAC/metadata.h>++/* Stream info */++unsigned FLAC__metadata_get_min_blocksize(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_max_blocksize(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_min_framesize(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_max_framesize(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_sample_rate(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_channels(FLAC__StreamMetadata *);+unsigned FLAC__metadata_get_bits_per_sample(FLAC__StreamMetadata *);+FLAC__uint64 FLAC__metadata_get_total_samples(FLAC__StreamMetadata *);+FLAC__byte *FLAC__metadata_get_md5sum(FLAC__StreamMetadata *);++/* Application */++FLAC__byte *FLAC__metadata_get_application_id(FLAC__StreamMetadata *);+FLAC__byte *FLAC__metadata_get_application_data(FLAC__StreamMetadata *, unsigned *);+void FLAC__metadata_set_application_id(FLAC__StreamMetadata *, FLAC__byte *);+FLAC__bool FLAC__metadata_set_application_data(FLAC__StreamMetadata *, FLAC__byte *, unsigned);++/* Seek table */++unsigned FLAC__metadata_get_seek_points_num(FLAC__StreamMetadata *);+FLAC__StreamMetadata_SeekPoint *FLAC__metadata_get_seek_point(FLAC__StreamMetadata *, unsigned);+void FLAC__metadata_set_seek_point(FLAC__StreamMetadata *, unsigned, FLAC__uint64, FLAC__uint64, unsigned);++/* Vorbis comment */++FLAC__byte *FLAC__metadata_get_vorbis_vendor(FLAC__StreamMetadata *, FLAC__uint32 *);+FLAC__bool FLAC__metadata_set_vorbis_vendor(FLAC__StreamMetadata *, FLAC__byte *, FLAC__uint32);+FLAC__byte *FLAC__metadata_get_vorbis_comment(FLAC__StreamMetadata *, const char*, FLAC__uint32 *);+FLAC__bool FLAC__metadata_set_vorbis_comment(FLAC__StreamMetadata *, FLAC__byte *, FLAC__uint32);+FLAC__bool FLAC__metadata_delete_vorbis_comment(FLAC__StreamMetadata *, const char *);+FLAC__bool FLAC__metadata_is_vorbis_comment_empty(FLAC__StreamMetadata *);++/* CUE sheet */++char *FLAC__metadata_get_cue_sheet_mcn(FLAC__StreamMetadata *);+FLAC__uint64 FLAC__metadata_get_cue_sheet_lead_in(FLAC__StreamMetadata *);+FLAC__bool FLAC__metadata_get_cue_sheet_is_cd(FLAC__StreamMetadata *);+FLAC__byte FLAC__metadata_get_cue_sheet_num_tracks(FLAC__StreamMetadata *);++FLAC__uint64 FLAC__metadata_get_cue_sheet_track_offset(FLAC__StreamMetadata *, FLAC__byte);+char *FLAC__metadata_get_cue_sheet_track_isrc(FLAC__StreamMetadata *, FLAC__byte);+FLAC__bool FLAC__metadata_get_cue_sheet_track_audio(FLAC__StreamMetadata *, FLAC__byte);+FLAC__bool FLAC__metadata_get_cue_sheet_track_preemphasis(FLAC__StreamMetadata *, FLAC__byte);+FLAC__byte FLAC__metadata_get_cue_sheet_track_num_indices(FLAC__StreamMetadata *, FLAC__byte);+FLAC__bool FLAC__metadata_get_cue_sheet_track_has_pregap_index(FLAC__StreamMetadata *, FLAC__byte);+FLAC__uint64 FLAC__metadata_get_cue_sheet_track_index(FLAC__StreamMetadata *, FLAC__byte, FLAC__byte);++void FLAC__metadata_set_cue_sheet_mcn(FLAC__StreamMetadata *, char *, unsigned);+void FLAC__metadata_set_cue_sheet_lead_in(FLAC__StreamMetadata *, FLAC__uint64);+void FLAC__metadata_set_cue_sheet_is_cd(FLAC__StreamMetadata *, FLAC__bool);++void FLAC__metadata_set_cue_sheet_track_offset(FLAC__StreamMetadata *, FLAC__byte, FLAC__uint64);+void FLAC__metadata_set_cue_sheet_track_number(FLAC__StreamMetadata *, FLAC__byte, FLAC__byte);+void FLAC__metadata_set_cue_sheet_track_isrc(FLAC__StreamMetadata *, FLAC__byte, char *, unsigned);+void FLAC__metadata_set_cue_sheet_track_audio(FLAC__StreamMetadata *, FLAC__byte, FLAC__bool);+void FLAC__metadata_set_cue_sheet_track_pre_emphasis(FLAC__StreamMetadata *, FLAC__byte, FLAC__bool);+void FLAC__metadata_set_cue_sheet_track_index(FLAC__StreamMetadata *, FLAC__byte, FLAC__byte, FLAC__byte, FLAC__uint64);++/* Picture */++FLAC__StreamMetadata_Picture_Type FLAC__metadata_get_picture_type(FLAC__StreamMetadata *);+char *FLAC__metadata_get_picture_mime_type(FLAC__StreamMetadata *);+FLAC__byte *FLAC__metadata_get_picture_description(FLAC__StreamMetadata *);+FLAC__uint32 FLAC__metadata_get_picture_width(FLAC__StreamMetadata *);+FLAC__uint32 FLAC__metadata_get_picture_height(FLAC__StreamMetadata *);+FLAC__uint32 FLAC__metadata_get_picture_depth(FLAC__StreamMetadata *);+FLAC__uint32 FLAC__metadata_get_picture_colors(FLAC__StreamMetadata *);+FLAC__byte *FLAC__metadata_get_picture_data(FLAC__StreamMetadata *, FLAC__uint32 *);++void FLAC__metadata_set_picture_type(FLAC__StreamMetadata *, FLAC__StreamMetadata_Picture_Type);+void FLAC__metadata_set_picture_width(FLAC__StreamMetadata *, FLAC__uint32);+void FLAC__metadata_set_picture_height(FLAC__StreamMetadata *, FLAC__uint32);+void FLAC__metadata_set_picture_depth(FLAC__StreamMetadata *, FLAC__uint32);+void FLAC__metadata_set_picture_colors(FLAC__StreamMetadata *, FLAC__uint32);++#endif /* FLAC__METADATA_LEVEL2_HELPERS_H */
+ cbits/stream_decoder_helpers.c view
@@ -0,0 +1,117 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#include "stream_decoder_helpers.h"++static unsigned round_to_bytes(unsigned bits)+{+  return (bits + (bits % 8)) / 8;+}++static FLAC__StreamDecoderWriteStatus write_callback+  ( const FLAC__StreamDecoder *decoder+  , const FLAC__Frame *frame+  , const FLAC__int32 *const ibuffer[]+  , void *obuffer)+{+  FLAC__uint64 i, ch;+  unsigned channels = frame->header.channels;++  (void)decoder;++  switch (round_to_bytes(frame->header.bits_per_sample))+    {+      case 1:++        /* If sample width is equal or less than 8 bit, we deal with one+         * byte per sample and samples are unsigned as per WAVE spec. */+        for (i = 0; i < frame->header.blocksize; i++)+          {+            for (ch = 0; ch < channels; ch++)+              {+                /* Shift back into unsigned values by adding 0x7f. */+                *((FLAC__uint8 *)obuffer + i * channels + ch)+                  = (FLAC__uint8)ibuffer[ch][i] + 0x80;+              }+          }+        break;++      case 2:++        /* Here we have signed samples, each having width equal to 16+         * bits. */+        for (i = 0; i < frame->header.blocksize; i++)+          {+            for (ch = 0; ch < channels; ch++)+              {+                *((FLAC__int16 *)obuffer + i * channels + ch)+                  = (FLAC__int16)ibuffer[ch][i];+              }+          }+        break;++      case 3:++        /* Singed 24 bit samples. Going with 3 bytes step is not so+         * handy. */+        for (i = 0; i < frame->header.blocksize; i++)+          {+            for (ch = 0; ch < channels; ch++)+              {+                *(FLAC__int32 *)((FLAC__byte *)obuffer + (i * channels + ch) * 3)+                  = (FLAC__int32)ibuffer[ch][i];+              }+          }+        break;+    }++  return FLAC__STREAM_DECODER_WRITE_STATUS_CONTINUE;+}++static void error_callback+  ( const FLAC__StreamDecoder *decoder+  , FLAC__StreamDecoderErrorStatus status+  , void *client_data )+{+  (void)decoder, (void)status, (void)client_data;+  return;+}++FLAC__StreamDecoderInitStatus FLAC__stream_decoder_init_helper+  ( FLAC__StreamDecoder *decoder+  , char *ifile_name+  , void *buffer )+{+  return FLAC__stream_decoder_init_file+    (decoder, ifile_name, write_callback, NULL, error_callback, buffer);+}
+ cbits/stream_decoder_helpers.h view
@@ -0,0 +1,41 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#ifndef FLAC__STREAM_DECODER_HELPERS_H+#define FLAC__STREAM_DECODER_HELPERS_H++#include <FLAC/stream_decoder.h>++FLAC__StreamDecoderInitStatus FLAC__stream_decoder_init_helper(FLAC__StreamDecoder *, char *, void *);++#endif /* FLAC__STREAM_DECODER_HELPERS_H */
+ cbits/stream_encoder_helpers.c view
@@ -0,0 +1,160 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#include "stream_encoder_helpers.h"++static unsigned round_to_bytes(unsigned bits)+{+  return (bits + (bits % 8)) / 8;+}++FLAC__bool FLAC__stream_encoder_process_helper+  ( FLAC__StreamEncoder *encoder+  , FLAC__uint64 data_offset+  , FLAC__uint64 data_size+  , const char *ifile_name )+{+  unsigned channels = FLAC__stream_encoder_get_channels(encoder);+  unsigned bits_per_sample = FLAC__stream_encoder_get_bits_per_sample(encoder);+  unsigned msw = round_to_bytes(bits_per_sample); /* mono sample width */+  unsigned block_align = channels * msw;+  FLAC__uint64 samples_to_process = data_size / block_align;+  FLAC__uint64 read_size = 4096;+  void *buffer_raw = malloc(read_size * block_align + 1);+  FLAC__int32 *buffer = malloc(read_size * sizeof(FLAC__int32) * channels);+  FILE *ifile = fopen(ifile_name, "r");+  FLAC__uint64 samples;+  unsigned i;+  FLAC__int32 x;++  if (data_size % block_align)+    {+      free(buffer_raw);+      free(buffer);+      fclose(ifile);+      return false;+    }++  /* move position indicator to beginning of audio data */+  fseek(ifile, data_offset, SEEK_SET);++  while (samples_to_process)+    {+      /* The reading happens by blocks. Every block has read_size samples in+       * it (multi-channel samples, that is). Since we will be using the+       * value returned by fread as indicator of whether something went+       * wrong or not, we need to know beforehand how many samples we need+       * to read. */+      samples = read_size <= samples_to_process ? read_size : samples_to_process;++      /* Read the samples into the “raw” buffer, fail by returning false if+       * number of read samples differs from the expected. */+      if (fread(buffer_raw, block_align, samples, ifile) != samples)+        {+          free(buffer_raw);+          free(buffer);+          fclose(ifile);+          return false;+        }++      /* libFLAC wants samples as FLAC__int32 values, so we need to copy+       * the data into an array of FLAC__int32 values, because what we have+       * read so far probably has different sample width. */++      switch (msw)  /* mono sample width in bytes */+        {+          case 1:++            /* If sample width is equal or less than 8 bit, we deal with one+             * byte per sample and samples are unsigned as per WAVE spec. */+            for (i = 0; i < samples * channels; i++)+              {+                /* Need to center the range at 0 and use signed integer as+                 * per FLAC docs. */+                *(buffer + i) = *((FLAC__uint8 *)buffer_raw + i) - 0x80;+              }+            break;++          case 2:++            /* Here we have signed samples, each having width equal to 16+             * bits. */+            for (i = 0; i < samples * channels; i++)+              {+                /* FIXME Only works on little-endian architectures. */+                *(buffer + i) = *((FLAC__int16 *)buffer_raw + i);+              }+            break;++          case 3:++            /* Singed 24 bit samples. Going with 3 bytes step is not so+             * handy. */+            for (i = 0; i < samples * channels; i++)+              {+                /* FIXME Only works on little-endian architectures. */+                x = *(FLAC__int32 *)((FLAC__byte *)buffer_raw + i * 3);+                if (x & 0x800000) /* do sign extension */+                  x |= 0xff000000; /* negative */+                else+                  x &= 0x00ffffff; /* positive */+                *(buffer + i) = x;+              }+            break;++        default:++          /* Have something else? You are screwed. */+          free(buffer_raw);+          free(buffer);+          fclose(ifile);+          return false;+        }++      /* Finally the easy part: call FLAC encoder function and process the+       * block of data. */+      if (!FLAC__stream_encoder_process_interleaved(encoder, buffer, samples))+        {+          free(buffer_raw);+          free(buffer);+          fclose(ifile);+          return false;+        }+      samples_to_process -= samples;+    }++  free(buffer_raw);+  free(buffer);+  fclose(ifile);+  return true;+}
+ cbits/stream_encoder_helpers.h view
@@ -0,0 +1,43 @@+/*+ * This file is part of ‘flac’ package.+ *+ * Copyright © 2016–2017 Mark Karpov+ *+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * * Redistributions of source code must retain the above copyright notice,+ *   this list of conditions and the following disclaimer.+ *+ * * Redistributions in binary form must reproduce the above copyright+ *   notice, this list of conditions and the following disclaimer in the+ *   documentation and/or other materials provided with the distribution.+ *+ * * Neither the name Mark Karpov nor the names of contributors may be used to+ *   endorse or promote products derived from this software without specific+ *   prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+ * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+ * NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+ * OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+ * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#ifndef FLAC__STREAM_ENCODER_HELPERS_H+#define FLAC__STREAM_ENCODER_HELPERS_H++#include <FLAC/stream_encoder.h>+#include <stdlib.h>+#include <string.h>++FLAC__bool FLAC__stream_encoder_process_helper(FLAC__StreamEncoder *, FLAC__uint64, FLAC__uint64, const char *);++#endif /* FLAC__STREAM_ENCODER_HELPERS_H */
+ flac.cabal view
@@ -0,0 +1,128 @@+--+-- Cabal configuration for ‘flac’ package.+--+-- Copyright © 2016–2017 Mark Karpov <markkarpov@openmailbox.org>+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+--   to endorse or promote products derived from this software without+--   specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++name:                 flac+version:              0.1.0+cabal-version:        >= 1.10+license:              BSD3+license-file:         LICENSE.md+author:               Mark Karpov <markkarpov@openmailbox.org>+maintainer:           Mark Karpov <markkarpov@openmailbox.org>+homepage:             https://github.com/mrkkrp/flac+bug-reports:          https://github.com/mrkkrp/flac/issues+category:             Codec, Audio+synopsis:             Complete high-level binding to libFLAC+build-type:           Simple+description:          Complete high-level binding to libFLAC.+extra-doc-files:      CHANGELOG.md+                    , README.md+extra-source-files:   cbits/*.h+data-files:           audio-samples/sample.flac+                    , audio-samples/*.rf64+                    , audio-samples/*.wav++source-repository head+  type:               git+  location:           https://github.com/mrkkrp/flac.git++flag dev+  description:        Turn on development settings.+  manual:             True+  default:            False++library+  build-depends:      base             >= 4.8    && < 5.0+                    , bytestring       >= 0.2    && < 0.11+                    , containers       >= 0.5    && < 0.6+                    , data-default-class+                    , directory        >= 1.2.2  && < 1.3+                    , exceptions       >= 0.6    && < 0.9+                    , filepath         >= 1.2    && < 1.5+                    , mtl              >= 2.0    && < 3.0+                    , text             >= 0.2    && < 1.3+                    , transformers     >= 0.4    && < 0.6+                    , vector           >= 0.10   && < 0.12+                    , wave             >= 0.1.2  && < 0.2+  if !impl(ghc >= 8.0)+    build-depends:    semigroups       == 0.18.*+  extra-libraries:    FLAC+  exposed-modules:    Codec.Audio.FLAC.Metadata+                    , Codec.Audio.FLAC.Metadata.CueSheet+                    , Codec.Audio.FLAC.StreamDecoder+                    , Codec.Audio.FLAC.StreamEncoder+                    , Codec.Audio.FLAC.StreamEncoder.Apodization+  other-modules:      Codec.Audio.FLAC.Metadata.Internal.Level2Interface+                    , Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers+                    , Codec.Audio.FLAC.Metadata.Internal.Object+                    , Codec.Audio.FLAC.Metadata.Internal.Types+                    , Codec.Audio.FLAC.StreamDecoder.Internal+                    , Codec.Audio.FLAC.StreamDecoder.Internal.Helpers+                    , Codec.Audio.FLAC.StreamDecoder.Internal.Types+                    , Codec.Audio.FLAC.StreamEncoder.Internal+                    , Codec.Audio.FLAC.StreamEncoder.Internal.Helpers+                    , Codec.Audio.FLAC.StreamEncoder.Internal.Types+                    , Codec.Audio.FLAC.Util+  extra-libraries:    FLAC+  c-sources:          cbits/metadata_level2_helpers.c+                    , cbits/stream_decoder_helpers.c+                    , cbits/stream_encoder_helpers.c+  include-dirs:       cbits+  if flag(dev)+    ghc-options:      -Wall -Werror -fsimpl-tick-factor=150+  else+    ghc-options:      -O2 -Wall -fsimpl-tick-factor=150+  default-language:   Haskell2010++test-suite tests+  main-is:            Spec.hs+  other-modules:      Codec.Audio.FLAC.MetadataSpec+                    , Codec.Audio.FLAC.StreamEncoderSpec+  hs-source-dirs:     tests+  type:               exitcode-stdio-1.0+  build-depends:      base             >= 4.8    && < 5.0+                    , bytestring       >= 0.2    && < 0.11+                    , data-default-class+                    , directory        >= 1.2.2  && < 1.3+                    , filepath         >= 1.2    && < 1.5+                    , flac             >= 0.1.0+                    , hspec            >= 2.0    && < 3.0+                    , temporary        >= 1.1    && < 1.3+                    , transformers     >= 0.4    && < 0.6+                    , vector           >= 0.10   && < 0.12+                    , wave             >= 0.1.2  && < 0.2+  if !impl(ghc >= 8.0)+    build-depends:    semigroups       == 0.18.*+  if flag(dev)+    ghc-options:      -Wall -Werror+  else+    ghc-options:      -O2 -Wall+  default-language:   Haskell2010
+ tests/Codec/Audio/FLAC/MetadataSpec.hs view
@@ -0,0 +1,546 @@+--+-- Test suite for metadata manipulation.+--+-- Copyright © 2016–2017 Mark Karpov <markkarpov@openmailbox.org>+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+--   to endorse or promote products derived from this software without+--   specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE OverloadedStrings #-}++module Codec.Audio.FLAC.MetadataSpec+  ( spec )+where++import Codec.Audio.FLAC.Metadata hiding (runFlacMeta)+import Codec.Audio.FLAC.Metadata.CueSheet+import Codec.Audio.Wave+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString (ByteString)+import Data.Default.Class+import Data.List.NonEmpty (NonEmpty (..))+import Data.Vector (Vector)+import System.Directory+import System.IO.Temp (withSystemTempFile)+import Test.Hspec hiding (shouldBe, shouldReturn)+import qualified Codec.Audio.FLAC.Metadata as Flac+import qualified Data.ByteString           as B+import qualified Data.List.NonEmpty        as NE+import qualified Data.Vector               as V+import qualified Test.Hspec                as Hspec++-- TODO How to share the same sandbox between several subsequent tests? This+-- would allow for more precise labelling.++spec :: Spec+spec = around withSandbox $ do+  describe "MinBlockSize" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve MinBlockSize `shouldReturn` 4096++  describe "MaxBlockSize" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve MaxBlockSize `shouldReturn` 4096++  describe "MinFrameSize" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve MinFrameSize `shouldReturn` 1270++  describe "MaxFrameSize" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve MaxFrameSize `shouldReturn` 2504++  describe "SampleRate" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve SampleRate `shouldReturn` 44100++  describe "Channels" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve Channels `shouldReturn` 2++  describe "ChannelMask" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve ChannelMask `shouldReturn` speakerStereo++  describe "BitsPerSample" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve BitsPerSample `shouldReturn` 16++  describe "TotalSamples" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve TotalSamples `shouldReturn` 18304++  describe "FileSize" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve FileSize `shouldReturn` 11459++  describe "BitRate" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve BitRate `shouldReturn` 220++  describe "MD5Sum" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve MD5Sum `shouldReturn` refMD5Sum++  describe "Duration" $+    it "is read correctly" $ \path ->+      runFlacMeta def path . checkNoMod $+        retrieve Duration `shouldReturn` 0.41505668934240364++  describe "Application" $+    it "is set/read/deleted correctly" $ \path -> do+      -- Can set application data.+      runFlacMeta def path $ do+        Application "foo"  =-> Just "foo"+        Application "bobo" =-> Just "bobo"+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [ApplicationBlock,ApplicationBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $ do+        retrieve (Application "foo")  `shouldReturn` Just "foo"+        retrieve (Application "bobo") `shouldReturn` Just "bobo"+      -- Can wipe one without affecting the other.+      runFlacMeta def path $ do+        Application "foo" =-> Nothing+        retrieve (Application "foo")  `shouldReturn` Nothing+        retrieve (Application "bobo") `shouldReturn` Just "bobo"+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [ApplicationBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can overwrite application data.+      runFlacMeta def path $ do+        Application "bobo" =-> Just "moon"+        retrieve (Application "bobo") `shouldReturn` Just "moon"+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [ApplicationBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can wipe the other one bringing it to the default state.+      runFlacMeta def path $ do+        Application "bobo" =-> Nothing+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $ do+        retrieve (Application "foo")  `shouldReturn` Nothing+        retrieve (Application "bobo") `shouldReturn` Nothing++  describe "SeekTable" $ do+    it "raises exception when invalid seek table given" $ \path -> do+      let m = runFlacMeta def path $+            SeekTable =-> Just invalidSeekTable+      m `shouldThrow` (== MetaInvalidSeekTable)+    it "is set/read/deleted correctly" $ \path -> do+      -- Can set seek table if it's correct.+      runFlacMeta def path $ do+        SeekTable =-> Just testSeekTable+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [SeekTableBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $+        retrieve SeekTable `shouldReturn` Just testSeekTable+      -- Can delete it.+      runFlacMeta def path $ do+        SeekTable =-> Nothing+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        SeekTable =-> Nothing+    context "when auto-vacuum disabled" $+      it "can write empty seek table" $ \path -> do+        runFlacMeta def { metaAutoVacuum = False } path $ do+          SeekTable =-> Just V.empty+          retrieve SeekTable `shouldReturn` Just V.empty+          getMetaChain `shouldReturn` StreamInfoBlock :|+            [SeekTableBlock,VorbisCommentBlock,PaddingBlock]+          isMetaChainModified `shouldReturn` True+        runFlacMeta def path . checkNoMod $+          retrieve SeekTable `shouldReturn` Just V.empty+    context "when auto-vacuum enabled" $+      it "empty seek table is removed automatically" $ \path -> do+        runFlacMeta def { metaAutoVacuum = True } path $ do+          SeekTable =-> Just V.empty+          retrieve SeekTable `shouldReturn` Just V.empty+          getMetaChain `shouldReturn` StreamInfoBlock :|+            [SeekTableBlock,VorbisCommentBlock,PaddingBlock]+          isMetaChainModified `shouldReturn` True+        runFlacMeta def path . checkNoMod $ do+          retrieve SeekTable `shouldReturn` Nothing+          getMetaChain `shouldReturn` refChain++  describe "VorbisVendor" $ do+    it "is set/read correctly" $ \path -> do+      -- Can set vorbis vendor.+      runFlacMeta def path $ do+        VorbisVendor =-> Just "foo"+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $+        retrieve VorbisVendor `shouldReturn` Just "foo"+    context "when auto-vacuum disabled" $+      it "deletion just sets the field to empty string" $ \path -> do+        runFlacMeta def { metaAutoVacuum = False } path $ do+          VorbisVendor =-> Nothing+          retrieve VorbisVendor `shouldReturn` Just ""+          getMetaChain `shouldReturn` StreamInfoBlock :|+            [VorbisCommentBlock,PaddingBlock]+          isMetaChainModified `shouldReturn` True+        runFlacMeta def path . checkNoMod $+          retrieve VorbisVendor `shouldReturn` Just ""+    context "when auto-vacuum enabled" $ do+      context "when no other vorbis fields set" $+        it "empty vendor causes removal of vorbis vendor block" $ \path -> do+          runFlacMeta def { metaAutoVacuum = True } path $ do+            VorbisVendor =-> Nothing+            retrieve VorbisVendor `shouldReturn` Just ""+            getMetaChain `shouldReturn` StreamInfoBlock :|+              [VorbisCommentBlock,PaddingBlock]+            isMetaChainModified `shouldReturn` True+          runFlacMeta def path . checkNoMod $ do+            retrieve VorbisVendor `shouldReturn` Nothing+            getMetaChain `shouldReturn` StreamInfoBlock :| [PaddingBlock]+      context "when other vorbis fields exist" $+        it "deletion just sets the field to empty string" $ \path -> do+          runFlacMeta def { metaAutoVacuum = True } path $ do+            VorbisComment Title =-> Just "bobla"+            VorbisVendor =-> Nothing+            retrieve VorbisVendor `shouldReturn` Just ""+            getMetaChain `shouldReturn` StreamInfoBlock :|+              [VorbisCommentBlock,PaddingBlock]+            isMetaChainModified `shouldReturn` True+          runFlacMeta def path . checkNoMod $ do+            retrieve VorbisVendor `shouldReturn` Just ""+            getMetaChain `shouldReturn` StreamInfoBlock :|+              [VorbisCommentBlock,PaddingBlock]++  describe "VorbisComment" . forM_ [minBound..maxBound] $ \vfield ->+    it (show vfield ++ " is set/read/deleted correctly") $ \path -> do+      -- Can set vorbis comment.+      runFlacMeta def path $ do+        VorbisComment vfield =-> Just "foo"+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $+        retrieve (VorbisComment vfield) `shouldReturn` Just "foo"+      -- Can delete it.+      runFlacMeta def path $ do+        VorbisComment vfield =-> Nothing+        retrieve (VorbisComment vfield) `shouldReturn` Nothing+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        retrieve (VorbisComment vfield) `shouldReturn` Nothing++  describe "CueSheet" $ do+    context "when the CUE sheet is for a CD" $+      it "raises exception when invalid CDDA CUE sheet is given" $ \path -> do+        let m = runFlacMeta def path $+              CueSheet =-> Just invalidCueSheet { cueIsCd = True }+            leadInError = "CD-DA cue sheet must have a lead-in length of at least 2 seconds"+        m `shouldThrow` (== MetaInvalidCueSheet leadInError)+    context "when the CUE sheet is not for a CD" $+      it "does not find anything bad in given CUE sheet" $ \path ->+        -- NOTE All other possible issues have been taken care of by the+        -- type system and carefully arranged data type definitions.+        runFlacMeta def path $+          CueSheet =-> Just invalidCueSheet { cueIsCd = False }+    it "is set/read/deleted correctly" $ \path -> do+      -- Can set CUE sheet if it's correct.+      runFlacMeta def path $ do+        CueSheet =-> Just testCueSheet+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [CueSheetBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $+        retrieve CueSheet `shouldReturn` Just testCueSheet+      -- Can delete it.+      runFlacMeta def path $ do+        CueSheet =-> Nothing+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        CueSheet =-> Nothing++  describe "Picture" . forM_ [minBound..maxBound] $ \ptype -> do+    it (show ptype ++ " raises exception on invalid picture") $ \path -> do+      let m = runFlacMeta def path $+            Picture ptype =-> Just invalidPicture+          mimeTypeError = "MIME type string must contain only printable ASCII characters (0x20-0x7e)"+      m `shouldThrow` (== MetaInvalidPicture mimeTypeError)+    it (show ptype ++ " is set/read/deleted correctly") $ \path -> do+      -- Can set a picture.+      runFlacMeta def path $ do+        Picture ptype =-> Just testPicture+        getMetaChain `shouldReturn` StreamInfoBlock :|+          [PictureBlock,VorbisCommentBlock,PaddingBlock]+        isMetaChainModified `shouldReturn` True+      -- Can read it back.+      runFlacMeta def path . checkNoMod $+        retrieve (Picture ptype) `shouldReturn` Just testPicture+      -- Can delete it.+      runFlacMeta def path $ do+        Picture ptype =-> Nothing+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        Picture ptype =-> Nothing++  describe "wipeVorbisComment" $+    it "wipes all “vorbis comment” metadata blocks" $ \path -> do+      runFlacMeta def path $ do+        VorbisComment Title  =-> Just "Title"+        VorbisComment Artist =-> Just "Artist"+      runFlacMeta def path $ do+        wipeVorbisComment+        getMetaChain `shouldReturn` StreamInfoBlock :| [PaddingBlock]+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        getMetaChain `shouldReturn` StreamInfoBlock :| [PaddingBlock]++  describe "wipeApplications" $+    it "wipes all “application” metadata blocks" $ \path -> do+      runFlacMeta def path $ do+        Application "foo"  =-> Just "foo"+        Application "bobo" =-> Just "bobo"+      runFlacMeta def path $ do+        wipeApplications+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        getMetaChain `shouldReturn` refChain++  describe "wipeSeekTable" $+    it "wipes all “seek table” metadata blocks" $ \path -> do+      runFlacMeta def path $+        SeekTable =-> Just testSeekTable+      runFlacMeta def path $ do+        wipeSeekTable+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        getMetaChain `shouldReturn` refChain++  describe "wipeCueSheets" $+    it "wipes all “CUE sheet” metadata blocks" $ \path -> do+      runFlacMeta def path $+        CueSheet =-> Just testCueSheet+      runFlacMeta def path $ do+        wipeCueSheets+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        getMetaChain `shouldReturn` refChain++  describe "wipePictures" $+    it "wipes all “picture” metadata blocks" $ \path -> do+      runFlacMeta def path $ do+        Picture PictureFrontCover =-> Just testPicture+        Picture PictureBackCover  =-> Just testPicture+      runFlacMeta def path $ do+        wipePictures+        getMetaChain `shouldReturn` refChain+        isMetaChainModified `shouldReturn` True+      runFlacMeta def path . checkNoMod $+        getMetaChain `shouldReturn` refChain++----------------------------------------------------------------------------+-- Helpers++infix 1 `shouldBe`, `shouldReturn`++-- | Lifted 'Hspec.shouldBe'.++shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m ()+shouldBe x y = liftIO (x `Hspec.shouldBe` y)++-- | Lifted 'Hspec.shouldReturn'.++shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m ()+shouldReturn m y = m >>= (`shouldBe` y)++-- | Type constrained version of 'Flac.runFlacMeta' to remove type+-- ambiguity.++runFlacMeta :: MetaSettings -> FilePath -> FlacMeta a -> IO a+runFlacMeta = Flac.runFlacMeta++-- | Make a temporary copy of @audio-samples/sample.flac@ file and provide+-- the path to the file. Automatically remove the file when the test+-- finishes.++withSandbox :: ActionWith FilePath -> IO ()+withSandbox action = withSystemTempFile "sample.flac" $ \path _ -> do+  copyFile "audio-samples/sample.flac" path+  action path++-- | Check that the inner action does not modify the chain.++checkNoMod :: FlacMeta a -> FlacMeta a+checkNoMod m = do+  chainBefore <- getMetaChain+  result <- m+  chainAfter  <- getMetaChain+  chainAfter `shouldBe` chainBefore+  isMetaChainModified `shouldReturn` False+  return result++-- | MD5 sum of uncompressed audio data of the unmodified sample we use in+-- these tests.++refMD5Sum :: ByteString+refMD5Sum = B.pack [89,191,106,236,125,27,65,161,78,138,172,153,91,60,42,109]++-- | The sequence of metadata blocks as they appear in the unmodified sample+-- we use in these tests.++refChain :: NonEmpty MetadataType+refChain = StreamInfoBlock :| [VorbisCommentBlock, PaddingBlock]++-- | A correct seek table.++testSeekTable :: Vector SeekPoint+testSeekTable = V.fromList+  [ SeekPoint 1 10 100+  , SeekPoint 2 20 108+  , SeekPoint 3 30 101 ]++-- | An invalid seek table.++invalidSeekTable :: Vector SeekPoint+invalidSeekTable = V.fromList+  [ SeekPoint 0 0 100+  , SeekPoint 0 0 108+  , SeekPoint 0 0 101 ]++-- | A correct CUE sheet.++testCueSheet :: CueSheetData+testCueSheet = CueSheetData+  { cueCatalog = "1112223334445"+  , cueLeadIn  = 88200 -- at least two seconds+  , cueIsCd    = True+  , cueTracks  =+    [ CueTrack+      { cueTrackOffset      = 588 * 2+      , cueTrackIsrc        = "abcde1234567"+      , cueTrackAudio       = True+      , cueTrackPreEmphasis = True+      , cueTrackPregapIndex = Nothing+      , cueTrackIndices     = NE.fromList [0,588,588 * 2] }+    , CueTrack+      { cueTrackOffset      = 588 * 3+      , cueTrackIsrc        = "abced1234576"+      , cueTrackAudio       = False+      , cueTrackPreEmphasis = False+      , cueTrackPregapIndex = Just 588+      , cueTrackIndices     = NE.fromList [0,588,588 * 7] }+    ]+  , cueLeadOutTrack =+      CueTrack+      { cueTrackOffset      = 588 * 10+      , cueTrackIsrc        = ""+      , cueTrackAudio       = True+      , cueTrackPreEmphasis = False+      , cueTrackPregapIndex = Just (588 * 9)+      , cueTrackIndices     = NE.fromList [0] }+  }++-- | An invalid CUE sheet.++invalidCueSheet :: CueSheetData+invalidCueSheet =  CueSheetData+  { cueCatalog = "1112223334445"+  , cueLeadIn  = 1401 -- less than two seconds — illegal+  , cueIsCd    = True+  , cueTracks  =+    [ CueTrack+      { cueTrackOffset      = 1212+      , cueTrackIsrc        = "abcde1234567"+      , cueTrackAudio       = True+      , cueTrackPreEmphasis = True+      , cueTrackPregapIndex = Nothing+      , cueTrackIndices     = NE.fromList [0,13,1096] }+    , CueTrack+      { cueTrackOffset      = 1313+      , cueTrackIsrc        = "abced1234576"+      , cueTrackAudio       = False+      , cueTrackPreEmphasis = False+      , cueTrackPregapIndex = Just 588+      , cueTrackIndices     = NE.fromList [0,19,1069] }+    ]+  , cueLeadOutTrack =+      CueTrack+      { cueTrackOffset      = 8888+      , cueTrackIsrc        = ""+      , cueTrackAudio       = True+      , cueTrackPreEmphasis = False+      , cueTrackPregapIndex = Just 588+      , cueTrackIndices     = NE.fromList [0]+      }+  }++-- | A correct picture.++testPicture :: PictureData+testPicture = PictureData+  { pictureMimeType    = "application/jpeg"+  , pictureDescription = "Good description."+  , pictureWidth       = 100+  , pictureHeight      = 100+  , pictureDepth       = 24+  , pictureColors      = 0+  , pictureData        = "Some picture data goes here, honest." }++-- | An invalid picture.++invalidPicture :: PictureData+invalidPicture = PictureData+  { pictureMimeType    = "application\1/jpeg"+  , pictureDescription = "Bad\1 description."+  , pictureWidth       = 100+  , pictureHeight      = 100+  , pictureDepth       = 24+  , pictureColors      = 0+  , pictureData        = "Some picture data goes here, honest." }
+ tests/Codec/Audio/FLAC/StreamEncoderSpec.hs view
@@ -0,0 +1,146 @@+--+-- Test suite for stream encoder.+--+-- Copyright © 2016–2017 Mark Karpov <markkarpov@openmailbox.org>+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- * Neither the name Mark Karpov nor the names of contributors may be used+--   to endorse or promote products derived from this software without+--   specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE RecordWildCards #-}++module Codec.Audio.FLAC.StreamEncoderSpec+  ( spec )+where++import Codec.Audio.FLAC.StreamDecoder+import Codec.Audio.FLAC.StreamEncoder+import Codec.Audio.Wave+import Control.Monad+import Data.ByteString (ByteString)+import Data.Default.Class+import System.Directory+import System.FilePath+import System.IO+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import qualified Data.ByteString as B++-- NOTE OK, we test here a lot of things at the same time, which may+-- disappoint adepts of various testing techniques and principles, but it's+-- easier to test many things simultaneously in this case, and when+-- something is not right, it's usually obvious what's wrong.++spec :: Spec+spec =+  describe "encodeFlac and decodeFlac" $+    withVariousWaves $+      it "encodes and decodes back correctly" $ \path -> do+        -- Input and output paths coincide on purpose, we test that nothing+        -- bad can happen in this case.+        old <- Blind <$> fetchWaveBody path+        -- We first let the built-in verification mechanics catch possible+        -- errors.+        encodeFlac def { encoderVerify = True } path path+        -- Then we let decoder check that the streams match with MD5 hash.+        decodeFlac def { decoderMd5Checking = True } path path+        -- But we also want to be sure that audio streams match+        -- byte-by-byte, we can't trust just FLAC's own checking.+        new <- Blind <$> fetchWaveBody path+        new `shouldBe` old++----------------------------------------------------------------------------+-- Helpers++newtype Blind a = Blind a++instance Eq a => Eq (Blind a) where+  (Blind x) == (Blind y) = x == y++instance Show (Blind a) where+  show _ = "<blind data cannot be shown>"++-- | Run given test with various WAVE files.++withVariousWaves :: SpecWith FilePath -> SpecWith ()+withVariousWaves m =+  forM_ waveFiles $ \(path, desc) ->+    context ("when given " ++ desc) (around (withSandbox path) m)++-- | Make a temporary copy of given file and provide the path to the file in+-- a sandbox directory. Automatically remove the files when the test+-- finishes.++withSandbox :: FilePath -> ActionWith FilePath -> IO ()+withSandbox path action =+  withSystemTempDirectory "flac-test" $ \dir -> do+    let path' = dir </> "файл" -- testing Unicode+    copyFile path path'+    action path'++-- | Extract body of given WAVE or RF64 file as a strict 'ByteString'.+-- Needless to say that the body should be relatively short.++fetchWaveBody :: FilePath -> IO ByteString+fetchWaveBody path = do+  Wave {..} <- readWaveFile path+  withBinaryFile path ReadMode $ \h -> do+    hSeek h AbsoluteSeek (fromIntegral waveDataOffset)+    B.hGet h (fromIntegral waveDataSize)++waveFiles :: [(FilePath, String)]+waveFiles =+  [ ( "audio-samples/1ch-44100hz-16bit.rf64"+    , "1 channel 44100 Hz 16 bit (RF64)" )+  , ( "audio-samples/1ch-44100hz-16bit.wav"+    , "1 channel 44100 Hz 16 bit (WAVE)" )+  , ( "audio-samples/1ch-44100hz-16bit-x.wav"+    , "1 channel 44100 Hz 16 bit (WAVEX)" )+  , ( "audio-samples/2ch-11025hz-24bit.rf64"+    , "2 channels 11025 Hz 24 bit (RF64)" )+  , ( "audio-samples/2ch-11025hz-24bit.wav"+    , "2 channels 11025 Hz 24 bit (WAVE)" )+  , ( "audio-samples/2ch-11025hz-24bit-x.wav"+    , "2 channels 11025 Hz 24 bit (WAVEX)" )+  , ( "audio-samples/2ch-8000hz-8bit.rf64"+    , "2 channels 8000 Hz 8 bit (RF64)" )+  , ( "audio-samples/2ch-8000hz-8bit.wav"+    , "2 channels 8000 Hz 8 bit (WAVE)" )+  , ( "audio-samples/2ch-8000hz-8bit-x.wav"+    , "2 channels 8000 Hz 8 bit (WAVEX)" )+  , ( "audio-samples/1ch-44100hz-8bit-full-range.wav"+    , "1 channel 44100 Hz 8 bit full range (WAVE)" )+  , ( "audio-samples/1ch-44100hz-8bit-silence.wav"+    , "1 channel 44100 Hz 8 bit silence (WAVE)" )+  , ( "audio-samples/1ch-44100hz-16bit-full-range.wav"+    , "1 channel 44100 Hz 16 bit full range (WAVE)" )+  , ( "audio-samples/1ch-44100hz-16bit-silence.wav"+    , "1 channel 44100 Hz 16 bit silence (WAVE)" )+  , ( "audio-samples/1ch-44100hz-24bit-full-range.wav"+    , "1 channel 44100 Hz 24 bit full range (WAVE)" )+  , ( "audio-samples/1ch-44100hz-24bit-silence.wav"+    , "1 channel 44100 Hz 24 bit silence (WAVE)" )+  ]
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}