{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Codec.Audio.FLAC.StreamDecoder
-- Copyright   :  © 2016–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- 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 the C implementation.
-- Decoding speed is equal to that of @flac@ command line tool. Memory
-- consumption is minimal and remains constant regardless of the size of
-- file to decode.
module Codec.Audio.FLAC.StreamDecoder
  ( DecoderSettings (..),
    defaultDecoderSettings,
    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.Function
import Data.IORef
import Foreign
import System.Directory
import System.IO

-- | Parameters of the stream decoder.
data DecoderSettings = DecoderSettings
  { -- | 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'.
    DecoderSettings -> Bool
decoderMd5Checking :: !Bool,
    -- | 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'.
    DecoderSettings -> WaveFormat
decoderWaveFormat :: !WaveFormat
  }
  deriving (Int -> DecoderSettings -> ShowS
[DecoderSettings] -> ShowS
DecoderSettings -> String
(Int -> DecoderSettings -> ShowS)
-> (DecoderSettings -> String)
-> ([DecoderSettings] -> ShowS)
-> Show DecoderSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecoderSettings] -> ShowS
$cshowList :: [DecoderSettings] -> ShowS
show :: DecoderSettings -> String
$cshow :: DecoderSettings -> String
showsPrec :: Int -> DecoderSettings -> ShowS
$cshowsPrec :: Int -> DecoderSettings -> ShowS
Show, ReadPrec [DecoderSettings]
ReadPrec DecoderSettings
Int -> ReadS DecoderSettings
ReadS [DecoderSettings]
(Int -> ReadS DecoderSettings)
-> ReadS [DecoderSettings]
-> ReadPrec DecoderSettings
-> ReadPrec [DecoderSettings]
-> Read DecoderSettings
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DecoderSettings]
$creadListPrec :: ReadPrec [DecoderSettings]
readPrec :: ReadPrec DecoderSettings
$creadPrec :: ReadPrec DecoderSettings
readList :: ReadS [DecoderSettings]
$creadList :: ReadS [DecoderSettings]
readsPrec :: Int -> ReadS DecoderSettings
$creadsPrec :: Int -> ReadS DecoderSettings
Read, DecoderSettings -> DecoderSettings -> Bool
(DecoderSettings -> DecoderSettings -> Bool)
-> (DecoderSettings -> DecoderSettings -> Bool)
-> Eq DecoderSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecoderSettings -> DecoderSettings -> Bool
$c/= :: DecoderSettings -> DecoderSettings -> Bool
== :: DecoderSettings -> DecoderSettings -> Bool
$c== :: DecoderSettings -> DecoderSettings -> Bool
Eq, Eq DecoderSettings
Eq DecoderSettings =>
(DecoderSettings -> DecoderSettings -> Ordering)
-> (DecoderSettings -> DecoderSettings -> Bool)
-> (DecoderSettings -> DecoderSettings -> Bool)
-> (DecoderSettings -> DecoderSettings -> Bool)
-> (DecoderSettings -> DecoderSettings -> Bool)
-> (DecoderSettings -> DecoderSettings -> DecoderSettings)
-> (DecoderSettings -> DecoderSettings -> DecoderSettings)
-> Ord DecoderSettings
DecoderSettings -> DecoderSettings -> Bool
DecoderSettings -> DecoderSettings -> Ordering
DecoderSettings -> DecoderSettings -> DecoderSettings
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DecoderSettings -> DecoderSettings -> DecoderSettings
$cmin :: DecoderSettings -> DecoderSettings -> DecoderSettings
max :: DecoderSettings -> DecoderSettings -> DecoderSettings
$cmax :: DecoderSettings -> DecoderSettings -> DecoderSettings
>= :: DecoderSettings -> DecoderSettings -> Bool
$c>= :: DecoderSettings -> DecoderSettings -> Bool
> :: DecoderSettings -> DecoderSettings -> Bool
$c> :: DecoderSettings -> DecoderSettings -> Bool
<= :: DecoderSettings -> DecoderSettings -> Bool
$c<= :: DecoderSettings -> DecoderSettings -> Bool
< :: DecoderSettings -> DecoderSettings -> Bool
$c< :: DecoderSettings -> DecoderSettings -> Bool
compare :: DecoderSettings -> DecoderSettings -> Ordering
$ccompare :: DecoderSettings -> DecoderSettings -> Ordering
$cp1Ord :: Eq DecoderSettings
Ord)

-- | Default 'DecoderSettings'.
--
-- @since 0.2.0
defaultDecoderSettings :: DecoderSettings
defaultDecoderSettings :: DecoderSettings
defaultDecoderSettings =
  $WDecoderSettings :: Bool -> WaveFormat -> DecoderSettings
DecoderSettings
    { decoderMd5Checking :: Bool
decoderMd5Checking = Bool
False,
      decoderWaveFormat :: WaveFormat
decoderWaveFormat = WaveFormat
WaveVanilla
    }

-- | Decode a FLAC file to WAVE.
--
-- 'DecoderException' is thrown when underlying FLAC decoder reports a
-- problem.
decodeFlac ::
  MonadIO m =>
  -- | Decoder settings
  DecoderSettings ->
  -- | File to decode
  FilePath ->
  -- | Where to save the resulting WAVE file
  FilePath ->
  m ()
decodeFlac :: DecoderSettings -> String -> String -> m ()
decodeFlac DecoderSettings {..} ipath' :: String
ipath' opath' :: String
opath' = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((Decoder -> IO ()) -> IO ()) -> (Decoder -> IO ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decoder -> IO ()) -> IO ()
forall a. (Decoder -> IO a) -> IO a
withDecoder ((Decoder -> IO ()) -> m ()) -> (Decoder -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \d :: Decoder
d -> do
  String
ipath <- String -> IO String
makeAbsolute String
ipath'
  String
opath <- String -> IO String
makeAbsolute String
opath'
  IO Bool -> IO ()
liftInit (Decoder -> Bool -> IO Bool
decoderSetMd5Checking Decoder
d Bool
decoderMd5Checking)
  (maxBlockSize :: Int
maxBlockSize, wave :: Wave
wave) <- MetaSettings -> String -> FlacMeta (Int, Wave) -> IO (Int, Wave)
forall (m :: * -> *) a.
MonadIO m =>
MetaSettings -> String -> FlacMeta a -> m a
runFlacMeta MetaSettings
defaultMetaSettings String
ipath (FlacMeta (Int, Wave) -> IO (Int, Wave))
-> FlacMeta (Int, Wave) -> IO (Int, Wave)
forall a b. (a -> b) -> a -> b
$ do
    let waveFileFormat :: WaveFormat
waveFileFormat = WaveFormat
decoderWaveFormat
        waveDataOffset :: Word32
waveDataOffset = 0
        waveDataSize :: Word64
waveDataSize = 0
        waveOtherChunks :: [a]
waveOtherChunks = []
    Word32
waveSampleRate <- SampleRate -> FlacMeta (MetaType SampleRate)
forall a. MetaValue a => a -> FlacMeta (MetaType a)
retrieve SampleRate
SampleRate
    SampleFormat
waveSampleFormat <-
      Word16 -> SampleFormat
SampleFormatPcmInt (Word16 -> SampleFormat)
-> (Word32 -> Word16) -> Word32 -> SampleFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        (Word32 -> SampleFormat)
-> FlacMeta Word32 -> FlacMeta SampleFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BitsPerSample -> FlacMeta (MetaType BitsPerSample)
forall a. MetaValue a => a -> FlacMeta (MetaType a)
retrieve BitsPerSample
BitsPerSample
    Set SpeakerPosition
waveChannelMask <- ChannelMask -> FlacMeta (MetaType ChannelMask)
forall a. MetaValue a => a -> FlacMeta (MetaType a)
retrieve ChannelMask
ChannelMask
    Word64
waveSamplesTotal <- TotalSamples -> FlacMeta (MetaType TotalSamples)
forall a. MetaValue a => a -> FlacMeta (MetaType a)
retrieve TotalSamples
TotalSamples
    Int
maxBlockSize <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> FlacMeta Word32 -> FlacMeta Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaxBlockSize -> FlacMeta (MetaType MaxBlockSize)
forall a. MetaValue a => a -> FlacMeta (MetaType a)
retrieve MaxBlockSize
MaxBlockSize
    (Int, Wave) -> FlacMeta (Int, Wave)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
maxBlockSize, $WWave :: WaveFormat
-> Word32
-> SampleFormat
-> Set SpeakerPosition
-> Word32
-> Word64
-> Word64
-> [(ByteString, ByteString)]
-> Wave
Wave {..})
  let bufferSize :: Int
bufferSize = Int
maxBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Wave -> Word16
waveBlockAlign Wave
wave) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
  String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withTempFile' String
opath ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \otemp :: String
otemp ->
    IO (Ptr Void)
-> (Ptr Void -> IO ()) -> (Ptr Void -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO (Ptr Void)
forall a. Int -> IO (Ptr a)
mallocBytes Int
bufferSize) Ptr Void -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr Void -> IO ()) -> IO ()) -> (Ptr Void -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \buffer :: Ptr Void
buffer -> do
      DecoderInitStatus
initStatus <- Decoder -> String -> Ptr Void -> IO DecoderInitStatus
decoderInitHelper Decoder
d String
ipath Ptr Void
buffer
      case DecoderInitStatus
initStatus of
        DecoderInitStatusOK -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        status :: DecoderInitStatus
status -> DecoderException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (DecoderInitStatus -> DecoderException
DecoderInitFailed DecoderInitStatus
status)
      Decoder -> IO Bool -> IO ()
liftBool Decoder
d (Decoder -> IO Bool
decoderProcessUntilEndOfMetadata Decoder
d)
      IORef Word64
processedRef <- Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
newIORef (0 :: Word64)
      String -> Wave -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *).
MonadIO m =>
String -> Wave -> (Handle -> IO ()) -> m ()
writeWaveFile String
otemp Wave
wave ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \nextOne :: IO ()
nextOne -> do
        Word64
processed <- IORef Word64 -> IO Word64
forall a. IORef a -> IO a
readIORef IORef Word64
processedRef
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
processed Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Wave -> Word64
waveSamplesTotal Wave
wave) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Decoder -> IO Bool -> IO ()
liftBool Decoder
d (Decoder -> IO Bool
decoderProcessSingle Decoder
d)
          Int
frameSize <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> IO Word32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder -> IO Word32
decoderGetBlockSize Decoder
d
          let toGrab :: Int
toGrab = Int
frameSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Wave -> Word16
waveBlockAlign Wave
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.
          Handle -> Ptr Void -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Void
buffer Int
toGrab
          IORef Word64 -> (Word64 -> Word64) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Word64
processedRef (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frameSize)
          IO ()
nextOne
      Decoder -> IO Bool -> IO ()
liftBool Decoder
d (Decoder -> IO Bool
decoderFinish Decoder
d)
      String -> String -> IO ()
renameFile String
otemp String
opath

----------------------------------------------------------------------------
-- Helpers

-- | Execute an initializing action that returns 'False' on failure and take
-- care of error reporting. In the case of trouble, @'DecoderInitFailed'
-- 'DecoderInitStatusAlreadyInitialized'@ is thrown.
liftInit :: IO Bool -> IO ()
liftInit :: IO Bool -> IO ()
liftInit m :: IO Bool
m = IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
m IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool IO ()
forall a. IO a
t (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  where
    t :: IO a
t = DecoderException -> IO a
forall e a. Exception e => e -> IO a
throwIO (DecoderInitStatus -> DecoderException
DecoderInitFailed DecoderInitStatus
DecoderInitStatusAlreadyInitialized)

-- | Execute an action that returns 'False' on failure into taking care of
-- error reporting. In the case of trouble @'EncoderFailed'@ with encoder
-- status attached is thrown.
liftBool :: Decoder -> IO Bool -> IO ()
liftBool :: Decoder -> IO Bool -> IO ()
liftBool encoder :: Decoder
encoder m :: IO Bool
m = IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
m IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool (Decoder -> IO ()
forall a. Decoder -> IO a
throwState Decoder
encoder) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Get 'DecoderState' from a given 'Decoder' and throw it immediately.
throwState :: Decoder -> IO a
throwState :: Decoder -> IO a
throwState = Decoder -> IO DecoderState
decoderGetState (Decoder -> IO DecoderState)
-> (DecoderState -> IO a) -> Decoder -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> DecoderException -> IO a
forall e a. Exception e => e -> IO a
throwIO (DecoderException -> IO a)
-> (DecoderState -> DecoderException) -> DecoderState -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderState -> DecoderException
DecoderFailed