Utils.hs

{-# LANGUAGE FlexibleContexts #-}
module Network.Socketson.Internal.Utils where


-- transformer stuff:
import Data.Either.Combinators (mapLeft)
import Control.Monad.Base (MonadBase (..), liftBase)
import Control.Monad.Trans.Either (EitherT (..), left, right, runEitherT, bracketEitherT, hoistEither, bimapEitherT)
import Control.Monad.IO.Class (liftIO)
import Control.Exception (try, Exception (..))
-- concurrent:
import Control.Concurrent.MVar.Lifted
-- intern:
import Network.Socketson.ProtocolException

tryT :: Exception e => IO a -> EitherT e IO a
tryT m = do mx <- liftIO $ try m
            hoistEither mx

-- | 'tryTWS' catches 'WS.ConnectionException' and puts them into the 'EitherT ProtocolException IO' monad.
tryTWS :: IO a -> EitherT ProtocolException IO a
tryTWS m = do mx <- liftIO $ try m
              case mapLeft ConnectionException mx of
                Left e  -> left e
                Right x -> right x

embed :: MonadBase m (EitherT a m) => m (Either a b) -> EitherT a m b
embed meith =
  do eith <- liftBase meith
     hoistEither eith

mapLeftT :: (Functor m) => (e -> e') -> EitherT e m a -> EitherT e' m a
mapLeftT f = bimapEitherT f id

withMVarT :: MVar a -> (a -> EitherT ProtocolException IO b) -> EitherT ProtocolException IO b
withMVarT mvar =
     bracketEitherT (readMVar mvar)
                    (putMVar mvar)

modifyMVarT :: MVar a -> (a -> EitherT ProtocolException IO (a, b)) -> EitherT ProtocolException IO b
modifyMVarT mvar mf = embed $
  modifyMVar mvar (\var ->
    do meith <- runEitherT (mf var)
       case meith of
         Left e          -> return (var, Left e)
         Right (var', x) -> return (var', Right x) )