Marshal.hs

{-# LANGUAGE ForeignFunctionInterface #-}

{-|
Description:    Utility functions for the libcdio FFI.

Copyright:      (c) 2018-2021 Sam May
License:        GPL-3.0-or-later
Maintainer:     ag@eitilt.life

Stability:      provisional
Portability:    portable
-}
module Foreign.Libcdio.Marshal
    ( -- * Types
      -- ** Cdio
      Cdio
    , withCdio
    , withCdio_
    , withCdioPtr
    , peekCdio
      -- ** CdText
    , CdText
    , withCdText
    , withCdText'
    , withCdText_
    , hasCdText
    , cdTextDataInit
      -- * Management
    , setupLogger
    , genBitArray
      -- * Marshalling
      -- ** Bool
    , errorOrBool
    , bool3
      -- ** Int
    , errorOrInt
    , maybeError
      -- ** Enum a
    , joinEnumFlags
    , modEnumFlags
      -- ** ByteString
    , peekByteStringLen
      -- ** String
    , allocaStringArray
      -- ** FString
    , peekFString
    , peekFStringArray
    ) where


import qualified Data.Array.BitArray as A
import qualified Data.Bits as B
import qualified Data.ByteString as BS
import qualified Data.Ix as I
import qualified Data.Maybe as Y

import qualified Foreign.C.String as C
import qualified Foreign.C.Types as C
import qualified Foreign.ForeignPtr as C
import qualified Foreign.Ptr as C

import qualified Foreign.Marshal.Alloc as M
import qualified Foreign.Marshal.Array as M
import qualified Foreign.Marshal.Utils as M

import qualified Foreign.Storable as S


-- | Helper to convert device capabilities to a bitfield.
genBitArray :: (Bounded a, I.Ix a) => [a] -> A.BitArray a
genBitArray [] = A.false (minBound, maxBound)
genBitArray cs = A.array (minBound, maxBound) $ map (\i -> (i, True)) cs


-- | A particular disc reading/writing device, along with the data contained
-- on the loaded disc.  Note well that this is always a mutable object, and is
-- not thread-safe; moreover, any function this is passed to may wind up
-- silently modifying the data.
data Cdio = Cdio (Maybe (C.ForeignPtr Cdio)) (Maybe (C.ForeignPtr CdText))

-- | Free all memory used by a reference to a device.
foreign import ccall "cdio/compat/device.h &cdio_destroy"
  cdioDestroy :: C.FinalizerPtr Cdio

-- | Convert the (foreign) reference to a device to something the FFI can use.
withCdio :: Cdio -> (C.Ptr Cdio -> IO b) -> IO (Maybe b)
withCdio (Cdio Nothing _) = const $ return Nothing
withCdio (Cdio (Just c) _) = fmap Just . C.withForeignPtr c

withCdio_ :: Cdio -> (C.Ptr Cdio -> IO ()) -> IO ()
withCdio_ c f = withCdio c f >> mempty

-- | Marshall a device reference with an extra layer of indirection.
withCdioPtr :: Cdio -> (C.Ptr (C.Ptr Cdio) -> IO b) -> IO (Maybe b)
withCdioPtr (Cdio Nothing _) _ = return Nothing
withCdioPtr (Cdio (Just c) _) f = M.alloca $ \p ->
    C.withForeignPtr c $ \c' -> do
        S.poke p c'
        Just <$> f p

-- | Un-marshall a newly-allocated pointer to a drive.
peekCdio :: C.Ptr Cdio -> IO Cdio
peekCdio c = do
    -- All public methods of opening 'Cdio' objects already have this earlier to
    -- catch any logs from opening the disc, but add it again just to be safe.
    setupLogger
    x <- M.maybePeek getCdText' c
    x' <- case x of
        Just x' -> Just <$> C.newForeignPtr_ x'
        Nothing -> return Nothing
    p' <- C.newForeignPtr cdioDestroy c
    return $ Cdio (Just p') x'

foreign import ccall "cdio/compat/disc.h cdio_get_cdtext"
  getCdText' :: C.Ptr Cdio -> IO (C.Ptr CdText)


-- | Initialize the log-management backend to use the mechanisms provided by
-- this library instead of just printing to standard output.  While this will
-- usually be taken care of automatically, it may still be necessary to call
-- this explicitly if messages are being recorded before any disc session is
-- opened.
foreign import ccall "cdio/compat/logging.h setup_cdio_logger"
  setupLogger :: IO ()


-- | The metadata describing the contents of a disc.
-- 
-- This type is not exported, and is mainly here to catch copy-paste errors on
-- my end.
data CdText

-- | Free all memory used by a reference to a device.
foreign import ccall "cdio/compat/cdtext.h &cdtext_destroy"
  cdTextDestroy :: C.FinalizerPtr CdText

-- | Convert the (foreign) reference to a device to something the FFI can use.
withCdText :: Cdio -> (C.Ptr CdText -> IO b) -> IO (Maybe b)
withCdText (Cdio _ Nothing) = const $ return Nothing
withCdText (Cdio _ (Just x)) = fmap Just <$> C.withForeignPtr x

withCdText' :: b -> Cdio -> (C.Ptr CdText -> IO b) -> IO b
withCdText' b c = fmap (Y.fromMaybe b) . withCdText c

withCdText_ :: Cdio -> (C.Ptr CdText -> IO ()) -> IO ()
withCdText_ c f = withCdText c f >> mempty

-- | Whether the various functions in "Foreign.Libcdio.CdText" will have any
-- effect, or simply return 'mempty'.
hasCdText :: Cdio -> Bool
hasCdText (Cdio _ x) = Y.isJust x


-- | Read binary CD-TEXT data into a structured datatype.
--
-- Note that binary CdText dumps will frequently include four bytes at the
-- beginning indicating the size of the file; this implementation expects that
-- those bytes /are not/ included.  If your dump does include them, @'BS.drop'
-- 4@ before passing the 'BS.ByteString' to this function.
-- 
-- /Before libcdio 0.94:  Always returns 'Nothing'/
cdTextDataInit :: BS.ByteString -> IO (Maybe Cdio)
cdTextDataInit bs = do
    setupLogger
    x <- cdTextInit' >>= C.newForeignPtr cdTextDestroy
    b <- BS.useAsCStringLen bs $ \(bs', l) -> withCdText (Cdio Nothing $ Just x) $ \x' ->
        cdTextDataInit' x' bs' $ fromIntegral l
    return $ if b == Just 0
        then Just . Cdio Nothing $ Just x
        else Nothing

-- | Create a new empty CDTEXT object.
foreign import ccall "cdio/compat/cdtext.h cdtext_init"
  cdTextInit' :: IO (C.Ptr CdText)

foreign import ccall safe "cdio/compat/cdtext.h cdtext_data_init_safe"
  cdTextDataInit' :: C.Ptr CdText -> C.Ptr C.CChar -> C.CSize -> IO C.CInt


-- | Free the memory indicated by a C-style pointer, avoiding a segfault if
-- passed a @NULL@ pointer.
cdioFree :: C.Ptr a -> IO ()
cdioFree = mkFree cdioFree'

foreign import ccall "cdio/memory.h &cdio_free"
  cdioFree' :: C.FunPtr (C.Ptr a -> IO ())

-- | Retrieve the actual function with a @free@-style signature.
foreign import ccall "dynamic"
  mkFree :: C.FunPtr (C.Ptr a -> IO ()) -> C.Ptr a -> IO ()


-- | Convert a return code indicating an error or success/failure into a
-- type-safe representation.
errorOrBool :: (Integral a, Enum b) => a -> Either b Bool
errorOrBool = fmap M.toBool . errorOrInt


-- | Convert the custom indeterminate boolean to more ideomatic Haskell.
bool3 :: C.CInt -> Maybe Bool
bool3 0 = Just False
bool3 1 = Just True
bool3 _ = Nothing


-- | Convert a return code indicating an error or a numeric value into a
-- type-safe representation.
errorOrInt :: (Integral a, Enum b) => a -> Either b a
errorOrInt i
    | i < 0 = Left . toEnum $ fromIntegral i
    | otherwise = Right i

-- | Filter out an error value expressed as part of a C-style enum.
maybeError :: Eq a => [a] -> a -> Maybe a
maybeError es i
    | elem i es = Nothing
    | otherwise = Just i


-- | Unmarshall a block of binary data from a C-style array with an explicit
-- length.  Returns 'Nothing' if the returned size is negative.
peekByteStringLen
    :: (Integral b, S.Storable b)
    => C.Ptr (C.Ptr a)
    -> C.Ptr b
    -> IO (Maybe BS.ByteString)
peekByteStringLen p l = do
    p' <- S.peek p
    l' <- S.peek l
    if l' < 0 || p' == C.nullPtr
         then return Nothing
         else Just <$> BS.packCStringLen (C.castPtr p', fromIntegral l')


-- | Combine an ordered value and an array of bit flags into a single value.
joinEnumFlags
    :: (Enum a, Enum b, Bounded b, I.Ix b, Integral c, B.Bits c)
    => a
    -> A.BitArray b
    -> c
joinEnumFlags a bs = fromIntegral (fromEnum a) + bs'
  where bs' = foldr set 0x0 . zip [fst bnds .. snd bnds] $ drop fstBit [0..]
        bnds = (minBound, maxBound)
        set (e, i) b = case bs A.!? e of
            Just True -> B.setBit b i
            _ -> b
        fstBit = B.countTrailingZeros . fromEnum $ fst bnds

-- | Split a number into an ordered value (below the 'minBound') and an array
-- of bit flags.
modEnumFlags
    :: (Integral a, B.Bits a, Enum b, Bounded b, Enum c, Bounded c, I.Ix c)
    => a
    -> (Maybe b, A.BitArray c)
modEnumFlags i = (toEnumMaybe $ fromIntegral fs, bs)
  where fs = mod i . fromIntegral . fromEnum $ fst bnds
        bs = A.listArray bnds . map (B.testBit i) . drop fstBit $ take lstBit [0..]
        bnds = (minBound, maxBound)
        fstBit = B.countTrailingZeros . fromEnum $ fst bnds
        lstBit = B.countTrailingZeros . fromEnum $ snd bnds


-- | Will not work if the 'Enum' instance has been redefined to not be
-- sequential.
-- 
-- From <https://stackoverflow.com/a/2744712/7634517>
toEnumMaybe :: (Enum a, Bounded a) => Int -> Maybe a
toEnumMaybe i = if i < fromEnum n || i > fromEnum x
    then Nothing
    else Just e
  where e = toEnum i
        n = asTypeOf minBound e
        x = asTypeOf maxBound e


-- | Temporarily copy a list of 'String's to pass them to a C function as a
-- @NULL@-terminated array, cleaning up the allocated memory afterward.
allocaStringArray :: [String] -> (C.Ptr C.CString -> IO a) -> IO a
allocaStringArray [] f = f C.nullPtr
allocaStringArray ss f = M.withMany C.withCString ss $ \ss' -> M.withArray0 C.nullPtr ss' f


-- | Retrieve the value of a C-style string which needs to be manually freed.
peekFString :: C.CString -> IO String
peekFString c = do
    s <- C.peekCString c
    cdioFree c
    return s

-- | Retrieve the values of an array of C-style strings which all need to be
-- manually freed.
peekFStringArray :: C.Ptr C.CString -> IO [String]
peekFStringArray p = do
    ss <- M.maybePeek (M.peekArray0 C.nullPtr) p
    maybe (return []) (mapM peekFString) ss