{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}

-- |
-- Module      :  Codec.Audio.FLAC.Metadata.Internal.Level2Interface
-- Copyright   :  © 2016–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Low-level Haskell wrapper around C functions to work with the level 2
-- FLAC metadata interface, see:
--
-- <https://xiph.org/flac/api/group__flac__metadata__level2.html>.
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

----------------------------------------------------------------------------
-- Chain

-- | Create and use a 'MetaChain' (metadata chain). The chain is guaranteed
-- to be freed even in the case of exception thrown.
--
-- If memory for the chain cannot be allocated, corresponding
-- 'MetaException' is raised.
withChain :: (MetaChain -> IO a) -> IO a
withChain :: (MetaChain -> IO a) -> IO a
withChain f :: MetaChain -> IO a
f = IO (Maybe MetaChain)
-> (Maybe MetaChain -> IO ()) -> (Maybe MetaChain -> IO a) -> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO (Maybe MetaChain)
chainNew ((MetaChain -> IO ()) -> Maybe MetaChain -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MetaChain -> IO ()
chainDelete) ((Maybe MetaChain -> IO a) -> IO a)
-> (Maybe MetaChain -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
  Nothing ->
    MetaException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
      (MetaChainStatus -> MetaException
MetaGeneralProblem MetaChainStatus
MetaChainStatusMemoryAllocationError)
  Just x :: MetaChain
x -> MetaChain -> IO a
f MetaChain
x

-- | Create a new 'MetaChain'. In the case of memory allocation problem
-- 'Nothing' is returned.
chainNew :: IO (Maybe MetaChain)
chainNew :: IO (Maybe MetaChain)
chainNew = MetaChain -> Maybe MetaChain
forall a p. Coercible a (Ptr p) => a -> Maybe a
maybePtr (MetaChain -> Maybe MetaChain)
-> IO MetaChain -> IO (Maybe MetaChain)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO MetaChain
c_chain_new

foreign import ccall unsafe "FLAC__metadata_chain_new"
  c_chain_new :: IO MetaChain

-- | Free a 'MetaChain' instance. Delete the object pointed to by
-- 'MetaChain'.
chainDelete :: MetaChain -> IO ()
chainDelete :: MetaChain -> IO ()
chainDelete = MetaChain -> IO ()
c_chain_delete

foreign import ccall unsafe "FLAC__metadata_chain_delete"
  c_chain_delete :: MetaChain -> IO ()

-- | Check status of a given 'MetaChain'. This can be used to find out what
-- went wrong. It also resets status to 'MetaChainStatusOK'.
chainStatus :: MetaChain -> IO MetaChainStatus
chainStatus :: MetaChain -> IO MetaChainStatus
chainStatus = (CUInt -> MetaChainStatus) -> IO CUInt -> IO MetaChainStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CUInt -> MetaChainStatus
forall a b. (Integral a, Enum b) => a -> b
toEnum' (IO CUInt -> IO MetaChainStatus)
-> (MetaChain -> IO CUInt) -> MetaChain -> IO MetaChainStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaChain -> IO CUInt
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 :: MetaChain -> FilePath -> IO Bool
chainRead chain :: MetaChain
chain path :: FilePath
path = FilePath -> (CString -> IO Bool) -> IO Bool
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
path (MetaChain -> CString -> IO Bool
c_chain_read MetaChain
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 ::
  -- | The chain to write
  MetaChain ->
  -- | Whether to use padding
  Bool ->
  -- | Whether to preserve file stats
  Bool ->
  -- | 'False' if something went wrong
  IO Bool
chainWrite :: MetaChain -> Bool -> Bool -> IO Bool
chainWrite chain :: MetaChain
chain usePadding :: Bool
usePadding preserveStats :: Bool
preserveStats =
  MetaChain -> CInt -> CInt -> IO Bool
c_chain_write MetaChain
chain (Bool -> CInt
forall a b. (Integral a, Enum b) => b -> a
fromEnum' Bool
usePadding) (Bool -> CInt
forall a b. (Integral a, Enum b) => b -> a
fromEnum' Bool
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 :: MetaChain -> IO ()
chainSortPadding = MetaChain -> IO ()
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 a 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) =>
  -- | Metadata chain to traverse
  MetaChain ->
  -- | Action to perform on each block
  (MetaIterator -> m (Maybe a)) ->
  -- | Accumulated results
  m [a]
withIterator :: MetaChain -> (MetaIterator -> m (Maybe a)) -> m [a]
withIterator chain :: MetaChain
chain f :: MetaIterator -> m (Maybe a)
f = m (Maybe MetaIterator)
-> (Maybe MetaIterator -> m ())
-> (Maybe MetaIterator -> m [a])
-> m [a]
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Maybe MetaIterator)
acquire Maybe MetaIterator -> m ()
release Maybe MetaIterator -> m [a]
action
  where
    acquire :: m (Maybe MetaIterator)
acquire = IO (Maybe MetaIterator) -> m (Maybe MetaIterator)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe MetaIterator)
iteratorNew
    release :: Maybe MetaIterator -> m ()
release = (MetaIterator -> m ()) -> Maybe MetaIterator -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (MetaIterator -> IO ()) -> MetaIterator -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaIterator -> IO ()
iteratorDelete)
    action :: Maybe MetaIterator -> m [a]
action mi :: Maybe MetaIterator
mi =
      case Maybe MetaIterator
mi of
        Nothing ->
          MetaException -> m [a]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
            (MetaChainStatus -> MetaException
MetaGeneralProblem MetaChainStatus
MetaChainStatusMemoryAllocationError)
        Just i :: MetaIterator
i -> do
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetaIterator -> MetaChain -> IO ()
iteratorInit MetaIterator
i MetaChain
chain)
          let go :: Bool -> m [a]
go thisNext :: Bool
thisNext =
                if Bool
thisNext
                  then do
                    Maybe a
res <- MetaIterator -> m (Maybe a)
f MetaIterator
i
                    let next :: m [a]
next = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetaIterator -> IO Bool
iteratorNext MetaIterator
i) m Bool -> (Bool -> m [a]) -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> m [a]
go
                    case Maybe a
res of
                      Nothing -> m [a]
next
                      Just x :: a
x -> (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [a]
next
                  else [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Bool -> m [a]
go Bool
True

-- | Create a new iterator. Return 'Nothing' if there was a problem with
-- memory allocation.
iteratorNew :: IO (Maybe MetaIterator)
iteratorNew :: IO (Maybe MetaIterator)
iteratorNew = MetaIterator -> Maybe MetaIterator
forall a p. Coercible a (Ptr p) => a -> Maybe a
maybePtr (MetaIterator -> Maybe MetaIterator)
-> IO MetaIterator -> IO (Maybe MetaIterator)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO MetaIterator
c_iterator_new

foreign import ccall unsafe "FLAC__metadata_iterator_new"
  c_iterator_new :: IO MetaIterator

-- | Free an iterator instance. Delete the object pointed to by
-- 'MetaIterator'.
iteratorDelete :: MetaIterator -> IO ()
iteratorDelete :: MetaIterator -> IO ()
iteratorDelete = MetaIterator -> IO ()
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 ::
  -- | Existing iterator
  MetaIterator ->
  -- | Existing initialized chain
  MetaChain ->
  IO ()
iteratorInit :: MetaIterator -> MetaChain -> IO ()
iteratorInit = MetaIterator -> MetaChain -> IO ()
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 :: MetaIterator -> IO Bool
iteratorNext = MetaIterator -> IO Bool
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 :: MetaIterator -> IO MetadataType
iteratorGetBlockType = (CUInt -> MetadataType) -> IO CUInt -> IO MetadataType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CUInt -> MetadataType
forall a b. (Integral a, Enum b) => a -> b
toEnum' (IO CUInt -> IO MetadataType)
-> (MetaIterator -> IO CUInt) -> MetaIterator -> IO MetadataType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaIterator -> IO CUInt
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 :: MetaIterator -> IO Metadata
iteratorGetBlock = MetaIterator -> IO Metadata
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 the position pointed to by
-- 'MetaIterator' replacing an existing block.
iteratorSetBlock :: MetaIterator -> Metadata -> IO Bool
iteratorSetBlock :: MetaIterator -> Metadata -> IO Bool
iteratorSetBlock = MetaIterator -> Metadata -> IO Bool
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 ::
  -- | Iterator that determines the position
  MetaIterator ->
  -- | 'False' if something went wrong
  IO Bool
iteratorDeleteBlock :: MetaIterator -> IO Bool
iteratorDeleteBlock block :: MetaIterator
block = MetaIterator -> Bool -> IO Bool
c_iterator_delete_block MetaIterator
block Bool
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 :: MetaIterator -> Metadata -> IO Bool
iteratorInsertBlockAfter = MetaIterator -> Metadata -> IO Bool
c_iterator_insert_block_after

foreign import ccall unsafe "FLAC__metadata_iterator_insert_block_after"
  c_iterator_insert_block_after :: MetaIterator -> Metadata -> IO Bool