diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## FLAC 0.1.0 + +* Initial release. diff --git a/Codec/Audio/FLAC/Metadata.hs b/Codec/Audio/FLAC/Metadata.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata.hs @@ -0,0 +1,971 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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: +-- +-- . +-- +-- __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: +-- +-- . +-- +-- '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 . + | 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@ +-- 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] diff --git a/Codec/Audio/FLAC/Metadata/CueSheet.hs b/Codec/Audio/FLAC/Metadata/CueSheet.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata/CueSheet.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata.CueSheet +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs @@ -0,0 +1,245 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata.Internal.Level2Interface +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Low-level Haskell wrapper around C functions to work with level 2 FLAC +-- metadata interface, see: +-- +-- . + +{-# 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 diff --git a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs @@ -0,0 +1,584 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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) diff --git a/Codec/Audio/FLAC/Metadata/Internal/Object.hs b/Codec/Audio/FLAC/Metadata/Internal/Object.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata/Internal/Object.hs @@ -0,0 +1,146 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata.Internal.Object +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Wrappers for functions to work with metadata objects, see: +-- +-- . + +{-# 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 diff --git a/Codec/Audio/FLAC/Metadata/Internal/Types.hs b/Codec/Audio/FLAC/Metadata/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Metadata/Internal/Types.hs @@ -0,0 +1,269 @@ +-- | +-- Module : Codec.Audio.FLAC.Metadata.Internal.Types +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 +-- 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) diff --git a/Codec/Audio/FLAC/StreamDecoder.hs b/Codec/Audio/FLAC/StreamDecoder.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamDecoder.hs @@ -0,0 +1,148 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamDecoder +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal.hs b/Codec/Audio/FLAC/StreamDecoder/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamDecoder/Internal.hs @@ -0,0 +1,111 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamDecoder.Internal +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs b/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamDecoder.Internal.Helpers +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs b/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs @@ -0,0 +1,93 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamDecoder.Internal.Types +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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) diff --git a/Codec/Audio/FLAC/StreamEncoder.hs b/Codec/Audio/FLAC/StreamEncoder.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamEncoder.hs @@ -0,0 +1,216 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamEncoder +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 +-- . +-- 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 diff --git a/Codec/Audio/FLAC/StreamEncoder/Apodization.hs b/Codec/Audio/FLAC/StreamEncoder/Apodization.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamEncoder/Apodization.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamEncoder.Apodization +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal.hs b/Codec/Audio/FLAC/StreamEncoder/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamEncoder/Internal.hs @@ -0,0 +1,266 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamEncoder.Internal +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Low-level Haskell wrapper around FLAC stream encoder API, see: +-- +-- + +{-# 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 diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs b/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs @@ -0,0 +1,92 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamEncoder.Internal.Helpers +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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: +-- . + +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 diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs b/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs @@ -0,0 +1,143 @@ +-- | +-- Module : Codec.Audio.FLAC.StreamEncoder.Internal.Types +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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) diff --git a/Codec/Audio/FLAC/Util.hs b/Codec/Audio/FLAC/Util.hs new file mode 100644 --- /dev/null +++ b/Codec/Audio/FLAC/Util.hs @@ -0,0 +1,86 @@ +-- | +-- Module : Codec.Audio.FLAC.Util +-- Copyright : © 2016–2017 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- 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 ()) diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/audio-samples/1ch-44100hz-16bit-full-range.wav b/audio-samples/1ch-44100hz-16bit-full-range.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-16bit-full-range.wav differ diff --git a/audio-samples/1ch-44100hz-16bit-silence.wav b/audio-samples/1ch-44100hz-16bit-silence.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-16bit-silence.wav differ diff --git a/audio-samples/1ch-44100hz-16bit-x.wav b/audio-samples/1ch-44100hz-16bit-x.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-16bit-x.wav differ diff --git a/audio-samples/1ch-44100hz-16bit.rf64 b/audio-samples/1ch-44100hz-16bit.rf64 new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-16bit.rf64 differ diff --git a/audio-samples/1ch-44100hz-16bit.wav b/audio-samples/1ch-44100hz-16bit.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-16bit.wav differ diff --git a/audio-samples/1ch-44100hz-24bit-full-range.wav b/audio-samples/1ch-44100hz-24bit-full-range.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-24bit-full-range.wav differ diff --git a/audio-samples/1ch-44100hz-24bit-silence.wav b/audio-samples/1ch-44100hz-24bit-silence.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-24bit-silence.wav differ diff --git a/audio-samples/1ch-44100hz-8bit-full-range.wav b/audio-samples/1ch-44100hz-8bit-full-range.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-8bit-full-range.wav differ diff --git a/audio-samples/1ch-44100hz-8bit-silence.wav b/audio-samples/1ch-44100hz-8bit-silence.wav new file mode 100644 Binary files /dev/null and b/audio-samples/1ch-44100hz-8bit-silence.wav differ diff --git a/audio-samples/2ch-11025hz-24bit-x.wav b/audio-samples/2ch-11025hz-24bit-x.wav new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-11025hz-24bit-x.wav differ diff --git a/audio-samples/2ch-11025hz-24bit.rf64 b/audio-samples/2ch-11025hz-24bit.rf64 new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-11025hz-24bit.rf64 differ diff --git a/audio-samples/2ch-11025hz-24bit.wav b/audio-samples/2ch-11025hz-24bit.wav new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-11025hz-24bit.wav differ diff --git a/audio-samples/2ch-8000hz-8bit-x.wav b/audio-samples/2ch-8000hz-8bit-x.wav new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-8000hz-8bit-x.wav differ diff --git a/audio-samples/2ch-8000hz-8bit.rf64 b/audio-samples/2ch-8000hz-8bit.rf64 new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-8000hz-8bit.rf64 differ diff --git a/audio-samples/2ch-8000hz-8bit.wav b/audio-samples/2ch-8000hz-8bit.wav new file mode 100644 Binary files /dev/null and b/audio-samples/2ch-8000hz-8bit.wav differ diff --git a/audio-samples/sample.flac b/audio-samples/sample.flac new file mode 100644 Binary files /dev/null and b/audio-samples/sample.flac differ diff --git a/cbits/metadata_level2_helpers.c b/cbits/metadata_level2_helpers.c new file mode 100644 --- /dev/null +++ b/cbits/metadata_level2_helpers.c @@ -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; +} diff --git a/cbits/metadata_level2_helpers.h b/cbits/metadata_level2_helpers.h new file mode 100644 --- /dev/null +++ b/cbits/metadata_level2_helpers.h @@ -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 +#include + +/* 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 */ diff --git a/cbits/stream_decoder_helpers.c b/cbits/stream_decoder_helpers.c new file mode 100644 --- /dev/null +++ b/cbits/stream_decoder_helpers.c @@ -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); +} diff --git a/cbits/stream_decoder_helpers.h b/cbits/stream_decoder_helpers.h new file mode 100644 --- /dev/null +++ b/cbits/stream_decoder_helpers.h @@ -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__StreamDecoderInitStatus FLAC__stream_decoder_init_helper(FLAC__StreamDecoder *, char *, void *); + +#endif /* FLAC__STREAM_DECODER_HELPERS_H */ diff --git a/cbits/stream_encoder_helpers.c b/cbits/stream_encoder_helpers.c new file mode 100644 --- /dev/null +++ b/cbits/stream_encoder_helpers.c @@ -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; +} diff --git a/cbits/stream_encoder_helpers.h b/cbits/stream_encoder_helpers.h new file mode 100644 --- /dev/null +++ b/cbits/stream_encoder_helpers.h @@ -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 +#include +#include + +FLAC__bool FLAC__stream_encoder_process_helper(FLAC__StreamEncoder *, FLAC__uint64, FLAC__uint64, const char *); + +#endif /* FLAC__STREAM_ENCODER_HELPERS_H */ diff --git a/flac.cabal b/flac.cabal new file mode 100644 --- /dev/null +++ b/flac.cabal @@ -0,0 +1,128 @@ +-- +-- Cabal configuration for ‘flac’ package. +-- +-- Copyright © 2016–2017 Mark Karpov +-- +-- 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 +maintainer: Mark Karpov +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 diff --git a/tests/Codec/Audio/FLAC/MetadataSpec.hs b/tests/Codec/Audio/FLAC/MetadataSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Codec/Audio/FLAC/MetadataSpec.hs @@ -0,0 +1,546 @@ +-- +-- Test suite for metadata manipulation. +-- +-- Copyright © 2016–2017 Mark Karpov +-- +-- 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." } diff --git a/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs b/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs @@ -0,0 +1,146 @@ +-- +-- Test suite for stream encoder. +-- +-- Copyright © 2016–2017 Mark Karpov +-- +-- 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 _ = "" + +-- | 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)" ) + ] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}