Cdio.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-|
Description:    Internal module to allow constructor access without pollution.

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

Stability:      stable
Portability:    non-portable (requires libcdio)
-}
module Sound.Libcdio.Types.Cdio
    ( Cdio
    , CdioError ( .. )
    , CdioErrorType ( .. )
    , Foreign.SessionArg ( .. )
    , Foreign.AccessMode ( .. )
    , liftCdio
    , liftCdio'
    , liftCdioError
    , liftCdioError'
    , packCdioError
    , packCdioError'
    , open
    , openMode
    , getArg
    , getAccessMode
    , runCdio
    ) where


import qualified Control.Applicative as A
#if MIN_VERSION_mtl(2,2,1)
import qualified Control.Monad.Except as N.E
#else
import qualified Control.Monad.Error as N.E
#endif
import qualified Control.Monad.Fail as N.F

import qualified Data.Text as T

import qualified Foreign.Libcdio.Device as Foreign
import qualified Foreign.Libcdio.Logging as Foreign

import Sound.Libcdio.Logging

import Control.Applicative ( (<|>) )
import Data.Array.BitArray ( (!) )


-- | A computation within the environment of the data (music or file) stored on
-- a CD.  The options for affecting that environment from within are limited by
-- design, as this library is intended for /reading/ discs rather than
-- /authoring/ them.
newtype Cdio a = Cdio (Foreign.Cdio -> IO (Either CdioError a))
instance Functor Cdio where
    fmap f (Cdio a) = Cdio $ \c -> fmap f <$> a c
instance Applicative Cdio where
    pure a = Cdio . const . return $ Right a
    Cdio f <*> Cdio a = Cdio $ \c -> do
        f' <- f c
        a' <- a c
        return $ f' <*> a'
-- | 'A.empty' fails with 'CdioEmpty'.
instance A.Alternative Cdio where
    empty = Cdio $ \_ -> return . Left . CdioError CdioEmpty $ T.pack "empty"
    Cdio f <|> Cdio g = Cdio $ \c -> f c <|> g c
instance Monad Cdio where
    Cdio a >>= f = Cdio $ \c -> do
        a' <- a c
        case a' of
            Left e -> return $ Left e
            Right x -> let Cdio b = f x in b c
-- | Wraps the text in a 'FreeformCdioError', for recovery with 'N.E.catchError'.
instance N.F.MonadFail Cdio where
    fail e = Cdio . const . return . flip errorText "fail" . FreeformCdioError $ T.pack e
instance N.E.MonadError CdioError Cdio where
    throwError err = Cdio . const . return $ Left err
    catchError (Cdio f) e = Cdio $ \c -> f c >>= \a' -> case a' of
        Left err ->
            let Cdio g = e err
            in  g c
        Right a -> return $ Right a
instance LibcdioLogger Cdio where
    logCutoff = Cdio $ \_ -> Right <$> Foreign.logCutoff
    setLogCutoff l = Cdio $ \_ -> Right <$> Foreign.setLogCutoff l
    readLog = Cdio $ \_ -> Right <$> Foreign.readLog
    clearLog = Cdio $ \_ -> Right <$> Foreign.clearLog
    putLog e = Cdio $ \_ -> Right <$> Foreign.putLog e

-- | Lift a computation from the C-style "Foreign.Libcdio" interface into the
-- monadic "Sound.Libcdio".
liftCdio :: (Foreign.Cdio -> IO a) -> Cdio a
liftCdio f = Cdio $ fmap Right . f

-- | As 'liftCdio', but for functions which take a second argument alongside
-- the read session.
liftCdio' :: (Foreign.Cdio -> a -> IO b) -> a -> Cdio b
liftCdio' f a = Cdio $ fmap Right . flip f a

-- | As 'liftCdio', but for functions which may return an error code indicating
-- failure.
liftCdioError :: (Foreign.Cdio -> IO (Either CdioError a)) -> Cdio a
{-# INLINE liftCdioError #-}
liftCdioError = Cdio

-- | As 'liftCdio'', but for functions which may return an error code indicating
-- failure.
liftCdioError' :: (Foreign.Cdio -> a -> IO (Either CdioError b)) -> a -> Cdio b
liftCdioError' f a = Cdio $ flip f a


-- | Associates a well-typed error with human-readable context information.
data CdioError = CdioError CdioErrorType T.Text
  deriving ( Eq, Show, Read )

-- | Potential situations which may cause a computation to fail.
data CdioErrorType
    = DriverError
        -- ^ A requested operation failed for some unknown reason, or the
        -- operating system doesn't support the 'Sound.Libcdio.Device.DriverId'
        -- in use.
    | BadParameter
        -- ^ Some value passed to a requested operation was rejected as
        -- nonsensical or otherwise breaking the value-level invariants.
    | NotPermitted
        -- ^ The ability to perform a requested operation has been restricted
        -- (e.g., the user doesn't have permission to access the disc drive).
    | SessionClosed
        -- ^ The underlying library closed the 'Cdio' session prematurely.
    | Unsupported
        -- ^ A requested operation isn't available with driver used by the
        -- 'Cdio' session.  Refer to 'Sound.Libcdio.Device.capabilities' and
        -- 'Sound.Libcdio.Device.deviceCapabilities' to reduce these.
    | CdioEmpty
        -- ^ 'A.empty' was called and no better alternative was encountered.
    | FreeformCdioError T.Text
        -- ^ Escape hatch from structured typing to allow user-specified
        -- (and user-triggered) errors.
  deriving ( Eq, Show, Read )

errorText :: CdioErrorType -> String -> Either CdioError a
errorText e = Left . CdioError e . T.pack

packCdioError :: String -> Foreign.DriverReturnCode -> a -> Either CdioError a
packCdioError _ Foreign.Success = Right
packCdioError s Foreign.DriverError = const $ errorText DriverError s
packCdioError s Foreign.Unsupported = const $ errorText Unsupported s
packCdioError s Foreign.Uninitialized = const $ errorText BadParameter s
packCdioError s Foreign.NotPermitted = const $ errorText NotPermitted s
packCdioError s Foreign.BadParameter = const $ errorText BadParameter s
packCdioError s Foreign.BadPointer = const $ errorText BadParameter s
packCdioError s Foreign.NoDriver = const $ errorText DriverError s
packCdioError _ Foreign.MmcSenseData = Right

packCdioError' :: String -> Either Foreign.DriverReturnCode a -> Either CdioError a
packCdioError' _ (Right a) = Right a
packCdioError' s (Left Foreign.Success) = errorText DriverError s
packCdioError' s (Left e) = packCdioError s e undefined


-- | Use a C-style @"Foreign.Libcdio".'Foreign.Cdio'@ object as the base to run
-- a Haskell-style @"Sound.Libcdio".'Cdio'@ computation.
-- 
-- Note that some invariants of the monadic interface may not work as expected
-- when used with the mutable objects.
runCdio :: Foreign.Cdio -> Cdio a -> IO (Either CdioError a)
runCdio c (Cdio f) = isolateLogs $ f c


-- | Open a session to read data from the disc drive/image at the given
-- location.  If passed 'Nothing' instead, uses the path considered "default";
-- on operating systems with a concept of numbered devices (e.g., Window's @D:@
-- drive, FreeBSD's @\/dev\/cd0@) will usually return the first such device
-- found to be suitable.
open
    :: Maybe FilePath
    -> Bool
        -- ^ Whether the disc should be ejected after the computation.
    -> Cdio a
    -> IO (Either CdioError a)
open = open' "open" Nothing


-- | Open a session to read data from the disc drive/image at the given
-- location, using a specific instruction set.  If passed 'Nothing' instead,
-- uses the path considered "default"; on operating systems with a concept of
-- numbered devices (e.g., Window's @D:@ drive, FreeBSD's @\/dev\/cd0@) will
-- usually return the first such device found to be suitable.
openMode
    :: Foreign.AccessMode
    -> Maybe FilePath
    -> Bool
        -- ^ Whether the disc should be ejected after the computation.
    -> Cdio a
    -> IO (Either CdioError a)
openMode = open' "openMode" . Just


open'
    :: String
        -- ^ The name of the calling function, for error reporting.
    -> Maybe Foreign.AccessMode
    -> Maybe FilePath
    -> Bool
        -- ^ Whether the disc should be ejected after the computation.
    -> Cdio a
    -> IO (Either CdioError a)
open' s m p e (Cdio f) = isolateLogs $ do
    -- Rely on the driver autodetect behaviour.
    c <-  case m of
        Just m' -> Foreign.cdioOpenAm p Foreign.DriverUnknown m'
        Nothing -> Foreign.cdioOpen p Foreign.DriverUnknown
    case c of
        Just c' -> do
            a <- f c'
            -- This isn't actually necessary since the failure code is ignored,
            -- but it's a small cost to be sure nothing weird happens (e.g.
            -- printing a warning message).
            (_, _, cap) <- Foreign.driveCap c'
            let e' = if e && cap ! Foreign.MiscEject
                then Foreign.ejectMedia c'
                else return Foreign.Success
            e' >> return a
        -- There may be a chance memory allocation fails, but far and away the
        -- most common is a path which is not actually a device.
        Nothing -> do
            return $ errorText BadParameter s


-- | Retrieve the session value associated with the given key.  The particular
-- case of @"access-mode"@ is instead handled by 'getAccessMode'.
getArg :: Foreign.SessionArg -> Cdio (Maybe T.Text)
getArg k = liftCdio $ \c -> do
    v <- Foreign.getArg c k
    return $ T.pack <$> v

-- | Check what instruction set is in use for reading the disc.  Other session
-- values are handled by 'getArg'.
getAccessMode :: Cdio (Maybe Foreign.AccessMode)
getAccessMode = liftCdio Foreign.getAccessMode