module Codec.Archive.Internal.Monad ( handle
                                    , ignore
                                    , lenient
                                    , runArchiveM
                                    , throwArchiveM
                                    -- * Bracketed resources within 'ArchiveM'
                                    , withCStringArchiveM
                                    , useAsCStringLenArchiveM
                                    , allocaBytesArchiveM
                                    , ArchiveM
                                    ) where

import           Codec.Archive.Types
import           Control.Exception      (throw)
import           Control.Monad          (void)
import           Control.Monad.Except   (ExceptT, runExceptT, throwError)
import           Control.Monad.IO.Class
import qualified Data.ByteString        as BS
import qualified Data.ByteString.Unsafe as BS
import           Foreign.C.String
import           Foreign.Marshal.Alloc  (allocaBytes)
import           Foreign.Ptr            (Ptr)

type ArchiveM = ExceptT ArchiveResult IO

-- for things we don't think is going to fail
ignore :: IO ArchiveResult -> ArchiveM ()
ignore :: IO ArchiveResult -> ArchiveM ()
ignore = ExceptT ArchiveResult IO ArchiveResult -> ArchiveM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ArchiveResult IO ArchiveResult -> ArchiveM ())
-> (IO ArchiveResult -> ExceptT ArchiveResult IO ArchiveResult)
-> IO ArchiveResult
-> ArchiveM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ArchiveResult -> ExceptT ArchiveResult IO ArchiveResult
forall a. IO a -> ExceptT ArchiveResult IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Throws 'ArchiveResult' on error.
--
-- @since 2.2.5.0
throwArchiveM :: ArchiveM a -> IO a
throwArchiveM :: forall a. ArchiveM a -> IO a
throwArchiveM = (Either ArchiveResult a -> a)
-> IO (Either ArchiveResult a) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ArchiveResult -> a) -> (a -> a) -> Either ArchiveResult a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ArchiveResult -> a
forall a e. Exception e => e -> a
throw a -> a
forall a. a -> a
id) (IO (Either ArchiveResult a) -> IO a)
-> (ArchiveM a -> IO (Either ArchiveResult a))
-> ArchiveM a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveM a -> IO (Either ArchiveResult a)
forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM

runArchiveM :: ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM :: forall a. ArchiveM a -> IO (Either ArchiveResult a)
runArchiveM = ExceptT ArchiveResult IO a -> IO (Either ArchiveResult a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

-- TODO: ArchiveFailed Writer monad?
-- archive_clear_error
lenient :: IO ArchiveResult -> ArchiveM ()
lenient :: IO ArchiveResult -> ArchiveM ()
lenient IO ArchiveResult
act = do
    ArchiveResult
res <- IO ArchiveResult -> ExceptT ArchiveResult IO ArchiveResult
forall a. IO a -> ExceptT ArchiveResult IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ArchiveResult
act
    case ArchiveResult
res of
        ArchiveResult
ArchiveFatal -> ArchiveResult -> ArchiveM ()
forall a e. Exception e => e -> a
throw ArchiveResult
res
        ArchiveResult
ArchiveEOF   -> ArchiveResult -> ArchiveM ()
forall a e. Exception e => e -> a
throw ArchiveResult
res
        ArchiveResult
_            -> () -> ArchiveM ()
forall a. a -> ExceptT ArchiveResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handle :: IO ArchiveResult -> ArchiveM ()
handle :: IO ArchiveResult -> ArchiveM ()
handle IO ArchiveResult
act = do
    ArchiveResult
res <- IO ArchiveResult -> ExceptT ArchiveResult IO ArchiveResult
forall a. IO a -> ExceptT ArchiveResult IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ArchiveResult
act
    case ArchiveResult
res of
        ArchiveResult
ArchiveOk    -> () -> ArchiveM ()
forall a. a -> ExceptT ArchiveResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        ArchiveResult
ArchiveRetry -> () -> ArchiveM ()
forall a. a -> ExceptT ArchiveResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- FIXME: ArchiveFailed may be ok
        ArchiveResult
x            -> ArchiveResult -> ArchiveM ()
forall a. ArchiveResult -> ExceptT ArchiveResult IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ArchiveResult
x

flipExceptIO :: IO (Either a b) -> ExceptT a IO b
flipExceptIO :: forall a b. IO (Either a b) -> ExceptT a IO b
flipExceptIO IO (Either a b)
act = do
    Either a b
res <- IO (Either a b) -> ExceptT a IO (Either a b)
forall a. IO a -> ExceptT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either a b)
act
    case Either a b
res of
        Right b
x -> b -> ExceptT a IO b
forall a. a -> ExceptT a IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
        Left a
y  -> a -> ExceptT a IO b
forall a. a -> ExceptT a IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a
y

genBracket :: (a -> (b -> IO (Either c d)) -> IO (Either c d)) -- ^ Function like 'withCString' we are trying to lift
           -> a -- ^ Fed to @b@
           -> (b -> ExceptT c IO d) -- ^ The action
           -> ExceptT c IO d
genBracket :: forall a b c d.
(a -> (b -> IO (Either c d)) -> IO (Either c d))
-> a -> (b -> ExceptT c IO d) -> ExceptT c IO d
genBracket a -> (b -> IO (Either c d)) -> IO (Either c d)
f a
x = IO (Either c d) -> ExceptT c IO d
forall a b. IO (Either a b) -> ExceptT a IO b
flipExceptIO (IO (Either c d) -> ExceptT c IO d)
-> ((b -> ExceptT c IO d) -> IO (Either c d))
-> (b -> ExceptT c IO d)
-> ExceptT c IO d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (b -> IO (Either c d)) -> IO (Either c d)
f a
x ((b -> IO (Either c d)) -> IO (Either c d))
-> ((b -> ExceptT c IO d) -> b -> IO (Either c d))
-> (b -> ExceptT c IO d)
-> IO (Either c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExceptT c IO d -> IO (Either c d)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT c IO d -> IO (Either c d))
-> (b -> ExceptT c IO d) -> b -> IO (Either c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

allocaBytesArchiveM :: Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c
allocaBytesArchiveM :: forall a b c. Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c
allocaBytesArchiveM = (Int -> (Ptr a -> IO (Either b c)) -> IO (Either b c))
-> Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c
forall a b c d.
(a -> (b -> IO (Either c d)) -> IO (Either c d))
-> a -> (b -> ExceptT c IO d) -> ExceptT c IO d
genBracket Int -> (Ptr a -> IO (Either b c)) -> IO (Either b c)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes

withCStringArchiveM :: String -> (CString -> ExceptT a IO b) -> ExceptT a IO b
withCStringArchiveM :: forall a b. String -> (CString -> ExceptT a IO b) -> ExceptT a IO b
withCStringArchiveM = (String -> (CString -> IO (Either a b)) -> IO (Either a b))
-> String -> (CString -> ExceptT a IO b) -> ExceptT a IO b
forall a b c d.
(a -> (b -> IO (Either c d)) -> IO (Either c d))
-> a -> (b -> ExceptT c IO d) -> ExceptT c IO d
genBracket String -> (CString -> IO (Either a b)) -> IO (Either a b)
forall a. String -> (CString -> IO a) -> IO a
withCString

useAsCStringLenArchiveM :: BS.ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b
useAsCStringLenArchiveM :: forall a b.
ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b
useAsCStringLenArchiveM = (ByteString -> (CStringLen -> IO (Either a b)) -> IO (Either a b))
-> ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b
forall a b c d.
(a -> (b -> IO (Either c d)) -> IO (Either c d))
-> a -> (b -> ExceptT c IO d) -> ExceptT c IO d
genBracket ByteString -> (CStringLen -> IO (Either a b)) -> IO (Either a b)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen