{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Marionette.Client where

import Control.Exception (AssertionFailed (AssertionFailed))
import Control.Monad (void, when)
import Control.Monad.Catch
    ( Exception (..)
    , MonadCatch
    , MonadMask
    , MonadThrow
    , catch
    , catchAll
    , throwM
    )
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (ReaderT (runReaderT))
import Control.Monad.Reader qualified as Reader
import Control.Monad.Reader.Class (MonadReader)
import Data.Aeson (AesonException (AesonException), FromJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Binary (Binary)
import Data.Binary qualified as Binary
import Data.Binary.Get qualified as Binary
import Data.ByteString (ByteString)
import Data.ByteString.Builder.Extra qualified as ByteString
import Data.IntMap.Strict qualified as IntMap
import Data.Maybe (isNothing)
import GHC.Stack (HasCallStack)
import Network.Simple.TCP
    ( HostName
    , ServiceName
    , SockAddr
    , Socket
    , closeSock
    , connectSock
    , sendLazy
    )
import Network.Socket.ByteString (recv)
import System.Timeout (timeout)
import Test.Marionette.Class (Marionette (..))
import Test.Marionette.Protocol
import UnliftIO
    ( MonadUnliftIO
    , TMVar
    , TQueue
    , async
    , bracket
    , isEmptyTMVar
    , link
    , readTMVar
    )
import UnliftIO.Concurrent (forkIO)
import UnliftIO.Retry (constantDelay, limitRetriesByCumulativeDelay, recoverAll)
import UnliftIO.STM
    ( atomically
    , modifyTVar'
    , newEmptyTMVarIO
    , newTQueueIO
    , newTVarIO
    , putTMVar
    , readTQueue
    , stateTVar
    , writeTQueue
    )
import Prelude hiding (log)

data SocketClosed = SocketClosed
    deriving stock (Int -> SocketClosed -> ShowS
[SocketClosed] -> ShowS
SocketClosed -> String
(Int -> SocketClosed -> ShowS)
-> (SocketClosed -> String)
-> ([SocketClosed] -> ShowS)
-> Show SocketClosed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketClosed -> ShowS
showsPrec :: Int -> SocketClosed -> ShowS
$cshow :: SocketClosed -> String
show :: SocketClosed -> String
$cshowList :: [SocketClosed] -> ShowS
showList :: [SocketClosed] -> ShowS
Show)
    deriving anyclass (Show SocketClosed
Typeable SocketClosed
(Typeable SocketClosed, Show SocketClosed) =>
(SocketClosed -> SomeException)
-> (SomeException -> Maybe SocketClosed)
-> (SocketClosed -> String)
-> (SocketClosed -> Bool)
-> Exception SocketClosed
SomeException -> Maybe SocketClosed
SocketClosed -> Bool
SocketClosed -> String
SocketClosed -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: SocketClosed -> SomeException
toException :: SocketClosed -> SomeException
$cfromException :: SomeException -> Maybe SocketClosed
fromException :: SomeException -> Maybe SocketClosed
$cdisplayException :: SocketClosed -> String
displayException :: SocketClosed -> String
$cbacktraceDesired :: SocketClosed -> Bool
backtraceDesired :: SocketClosed -> Bool
Exception)

newtype DecodeError = DecodeError String
    deriving stock (Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> String
(Int -> DecodeError -> ShowS)
-> (DecodeError -> String)
-> ([DecodeError] -> ShowS)
-> Show DecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeError -> ShowS
showsPrec :: Int -> DecodeError -> ShowS
$cshow :: DecodeError -> String
show :: DecodeError -> String
$cshowList :: [DecodeError] -> ShowS
showList :: [DecodeError] -> ShowS
Show)
    deriving anyclass (Show DecodeError
Typeable DecodeError
(Typeable DecodeError, Show DecodeError) =>
(DecodeError -> SomeException)
-> (SomeException -> Maybe DecodeError)
-> (DecodeError -> String)
-> (DecodeError -> Bool)
-> Exception DecodeError
SomeException -> Maybe DecodeError
DecodeError -> Bool
DecodeError -> String
DecodeError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: DecodeError -> SomeException
toException :: DecodeError -> SomeException
$cfromException :: SomeException -> Maybe DecodeError
fromException :: SomeException -> Maybe DecodeError
$cdisplayException :: DecodeError -> String
displayException :: DecodeError -> String
$cbacktraceDesired :: DecodeError -> Bool
backtraceDesired :: DecodeError -> Bool
Exception)

incoming
    :: forall m a
     . (MonadUnliftIO m, MonadThrow m, Binary a)
    => Socket
    -> m (TQueue a)
incoming :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadThrow m, Binary a) =>
Socket -> m (TQueue a)
incoming Socket
socket = do
    TQueue a
q <- m (TQueue a)
forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO
    Async (ZonkAny 0) -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link (Async (ZonkAny 0) -> m ()) -> m (Async (ZonkAny 0)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (ZonkAny 0) -> m (Async (ZonkAny 0))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async ((a -> m ()) -> Decoder a -> m (ZonkAny 0)
go (STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (a -> STM ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
q) (ByteString -> Decoder a
newDecoder ByteString
""))
    pure TQueue a
q
  where
    newDecoder :: ByteString -> Binary.Decoder a
    newDecoder :: ByteString -> Decoder a
newDecoder ByteString
bs = Get a -> Decoder a
forall a. Get a -> Decoder a
Binary.runGetIncremental Get a
forall t. Binary t => Get t
Binary.get Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
`Binary.pushChunk` ByteString
bs
    go :: (a -> m ()) -> Decoder a -> m (ZonkAny 0)
go a -> m ()
_ (Binary.Fail ByteString
_ ByteOffset
_ String
err) = DecodeError -> m (ZonkAny 0)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (DecodeError -> m (ZonkAny 0))
-> (String -> DecodeError) -> String -> m (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DecodeError
DecodeError (String -> m (ZonkAny 0)) -> String -> m (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ String
err
    go a -> m ()
f (Binary.Done ByteString
rest ByteOffset
_ a
a) = do
        a -> m ()
f a
a
        (a -> m ()) -> Decoder a -> m (ZonkAny 0)
go a -> m ()
f (Decoder a -> m (ZonkAny 0)) -> Decoder a -> m (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ ByteString -> Decoder a
newDecoder ByteString
rest
    go a -> m ()
f Decoder a
dec =
        (a -> m ()) -> Decoder a -> m (ZonkAny 0)
go a -> m ()
f (Decoder a -> m (ZonkAny 0))
-> (ByteString -> Decoder a) -> ByteString -> m (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decoder a
dec Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
`Binary.pushChunk`)
            (ByteString -> m (ZonkAny 0)) -> m ByteString -> m (ZonkAny 0)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                (Socket -> Int -> IO ByteString
recv Socket
socket Int
ByteString.defaultChunkSize IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` \SomeException
_ -> SocketClosed -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SocketClosed
SocketClosed)

connect
    :: (MonadUnliftIO m)
    => HostName
    -> ServiceName
    -> ((Socket, SockAddr) -> m a)
    -> m a
connect :: forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> ((Socket, SockAddr) -> m a) -> m a
connect String
host String
port =
    m (Socket, SockAddr)
-> ((Socket, SockAddr) -> m ())
-> ((Socket, SockAddr) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        ( RetryPolicyM m
-> (RetryStatus -> m (Socket, SockAddr)) -> m (Socket, SockAddr)
forall (m :: * -> *) a.
MonadUnliftIO m =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll (Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
5_000_000 (RetryPolicyM m -> RetryPolicyM m)
-> RetryPolicyM m -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
50_000)
            ((RetryStatus -> m (Socket, SockAddr)) -> m (Socket, SockAddr))
-> (m (Socket, SockAddr) -> RetryStatus -> m (Socket, SockAddr))
-> m (Socket, SockAddr)
-> m (Socket, SockAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Socket, SockAddr) -> RetryStatus -> m (Socket, SockAddr)
forall a b. a -> b -> a
const
            (m (Socket, SockAddr) -> m (Socket, SockAddr))
-> m (Socket, SockAddr) -> m (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ String -> String -> m (Socket, SockAddr)
forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Socket, SockAddr)
connectSock String
host String
port
        )
        (Socket -> m ()
forall (m :: * -> *). MonadIO m => Socket -> m ()
closeSock (Socket -> m ())
-> ((Socket, SockAddr) -> Socket) -> (Socket, SockAddr) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst)

newtype MarionetteTimeout = MarionetteTimeout MarionetteMessage
    deriving stock (Int -> MarionetteTimeout -> ShowS
[MarionetteTimeout] -> ShowS
MarionetteTimeout -> String
(Int -> MarionetteTimeout -> ShowS)
-> (MarionetteTimeout -> String)
-> ([MarionetteTimeout] -> ShowS)
-> Show MarionetteTimeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarionetteTimeout -> ShowS
showsPrec :: Int -> MarionetteTimeout -> ShowS
$cshow :: MarionetteTimeout -> String
show :: MarionetteTimeout -> String
$cshowList :: [MarionetteTimeout] -> ShowS
showList :: [MarionetteTimeout] -> ShowS
Show)
    deriving anyclass (Show MarionetteTimeout
Typeable MarionetteTimeout
(Typeable MarionetteTimeout, Show MarionetteTimeout) =>
(MarionetteTimeout -> SomeException)
-> (SomeException -> Maybe MarionetteTimeout)
-> (MarionetteTimeout -> String)
-> (MarionetteTimeout -> Bool)
-> Exception MarionetteTimeout
SomeException -> Maybe MarionetteTimeout
MarionetteTimeout -> Bool
MarionetteTimeout -> String
MarionetteTimeout -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: MarionetteTimeout -> SomeException
toException :: MarionetteTimeout -> SomeException
$cfromException :: SomeException -> Maybe MarionetteTimeout
fromException :: SomeException -> Maybe MarionetteTimeout
$cdisplayException :: MarionetteTimeout -> String
displayException :: MarionetteTimeout -> String
$cbacktraceDesired :: MarionetteTimeout -> Bool
backtraceDesired :: MarionetteTimeout -> Bool
Exception)

newtype UnexpectedResult = UnexpectedResult Result
    deriving stock (Int -> UnexpectedResult -> ShowS
[UnexpectedResult] -> ShowS
UnexpectedResult -> String
(Int -> UnexpectedResult -> ShowS)
-> (UnexpectedResult -> String)
-> ([UnexpectedResult] -> ShowS)
-> Show UnexpectedResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnexpectedResult -> ShowS
showsPrec :: Int -> UnexpectedResult -> ShowS
$cshow :: UnexpectedResult -> String
show :: UnexpectedResult -> String
$cshowList :: [UnexpectedResult] -> ShowS
showList :: [UnexpectedResult] -> ShowS
Show)
    deriving anyclass (Show UnexpectedResult
Typeable UnexpectedResult
(Typeable UnexpectedResult, Show UnexpectedResult) =>
(UnexpectedResult -> SomeException)
-> (SomeException -> Maybe UnexpectedResult)
-> (UnexpectedResult -> String)
-> (UnexpectedResult -> Bool)
-> Exception UnexpectedResult
SomeException -> Maybe UnexpectedResult
UnexpectedResult -> Bool
UnexpectedResult -> String
UnexpectedResult -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: UnexpectedResult -> SomeException
toException :: UnexpectedResult -> SomeException
$cfromException :: SomeException -> Maybe UnexpectedResult
fromException :: SomeException -> Maybe UnexpectedResult
$cdisplayException :: UnexpectedResult -> String
displayException :: UnexpectedResult -> String
$cbacktraceDesired :: UnexpectedResult -> Bool
backtraceDesired :: UnexpectedResult -> Bool
Exception)

data CommandWithCallback = CommandWithCallback Command (TMVar Result)

-- | A monad transformer that speaks the Marionette wire protocol over a TCP
-- socket. Run it with 'runMarionetteT'.
newtype MarionetteT m a = MarionetteT (ReaderT (TQueue CommandWithCallback) m a)
    deriving newtype
        ( (forall a b. (a -> b) -> MarionetteT m a -> MarionetteT m b)
-> (forall a b. a -> MarionetteT m b -> MarionetteT m a)
-> Functor (MarionetteT m)
forall a b. a -> MarionetteT m b -> MarionetteT m a
forall a b. (a -> b) -> MarionetteT m a -> MarionetteT m b
forall (m :: * -> *) a b.
Functor m =>
a -> MarionetteT m b -> MarionetteT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MarionetteT m a -> MarionetteT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MarionetteT m a -> MarionetteT m b
fmap :: forall a b. (a -> b) -> MarionetteT m a -> MarionetteT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> MarionetteT m b -> MarionetteT m a
<$ :: forall a b. a -> MarionetteT m b -> MarionetteT m a
Functor
        , Functor (MarionetteT m)
Functor (MarionetteT m) =>
(forall a. a -> MarionetteT m a)
-> (forall a b.
    MarionetteT m (a -> b) -> MarionetteT m a -> MarionetteT m b)
-> (forall a b c.
    (a -> b -> c)
    -> MarionetteT m a -> MarionetteT m b -> MarionetteT m c)
-> (forall a b.
    MarionetteT m a -> MarionetteT m b -> MarionetteT m b)
-> (forall a b.
    MarionetteT m a -> MarionetteT m b -> MarionetteT m a)
-> Applicative (MarionetteT m)
forall a. a -> MarionetteT m a
forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m a
forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m b
forall a b.
MarionetteT m (a -> b) -> MarionetteT m a -> MarionetteT m b
forall a b c.
(a -> b -> c)
-> MarionetteT m a -> MarionetteT m b -> MarionetteT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (MarionetteT m)
forall (m :: * -> *) a. Applicative m => a -> MarionetteT m a
forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m a
forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m b
forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m (a -> b) -> MarionetteT m a -> MarionetteT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> MarionetteT m a -> MarionetteT m b -> MarionetteT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> MarionetteT m a
pure :: forall a. a -> MarionetteT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m (a -> b) -> MarionetteT m a -> MarionetteT m b
<*> :: forall a b.
MarionetteT m (a -> b) -> MarionetteT m a -> MarionetteT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> MarionetteT m a -> MarionetteT m b -> MarionetteT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> MarionetteT m a -> MarionetteT m b -> MarionetteT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m b
*> :: forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m a
<* :: forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m a
Applicative
        , Applicative (MarionetteT m)
Applicative (MarionetteT m) =>
(forall a b.
 MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b)
-> (forall a b.
    MarionetteT m a -> MarionetteT m b -> MarionetteT m b)
-> (forall a. a -> MarionetteT m a)
-> Monad (MarionetteT m)
forall a. a -> MarionetteT m a
forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m b
forall a b.
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
forall (m :: * -> *). Monad m => Applicative (MarionetteT m)
forall (m :: * -> *) a. Monad m => a -> MarionetteT m a
forall (m :: * -> *) a b.
Monad m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m b
forall (m :: * -> *) a b.
Monad m =>
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
>>= :: forall a b.
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
MarionetteT m a -> MarionetteT m b -> MarionetteT m b
>> :: forall a b. MarionetteT m a -> MarionetteT m b -> MarionetteT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> MarionetteT m a
return :: forall a. a -> MarionetteT m a
Monad
        , Monad (MarionetteT m)
Monad (MarionetteT m) =>
(forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a)
-> MonadThrow (MarionetteT m)
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (MarionetteT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> MarionetteT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> MarionetteT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
MonadThrow
        , MonadThrow (MarionetteT m)
MonadThrow (MarionetteT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a)
-> MonadCatch (MarionetteT m)
forall e a.
(HasCallStack, Exception e) =>
MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a
forall (m :: * -> *). MonadCatch m => MonadThrow (MarionetteT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a
MonadCatch
        , MonadCatch (MarionetteT m)
MonadCatch (MarionetteT m) =>
(forall b.
 HasCallStack =>
 ((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
 -> MarionetteT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
    -> MarionetteT m b)
-> (forall a b c.
    HasCallStack =>
    MarionetteT m a
    -> (a -> ExitCase b -> MarionetteT m c)
    -> (a -> MarionetteT m b)
    -> MarionetteT m (b, c))
-> MonadMask (MarionetteT m)
forall b.
HasCallStack =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
forall a b c.
HasCallStack =>
MarionetteT m a
-> (a -> ExitCase b -> MarionetteT m c)
-> (a -> MarionetteT m b)
-> MarionetteT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (MarionetteT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
MarionetteT m a
-> (a -> ExitCase b -> MarionetteT m c)
-> (a -> MarionetteT m b)
-> MarionetteT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
mask :: forall b.
HasCallStack =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. MarionetteT m a -> MarionetteT m a) -> MarionetteT m b)
-> MarionetteT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
MarionetteT m a
-> (a -> ExitCase b -> MarionetteT m c)
-> (a -> MarionetteT m b)
-> MarionetteT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
MarionetteT m a
-> (a -> ExitCase b -> MarionetteT m c)
-> (a -> MarionetteT m b)
-> MarionetteT m (b, c)
MonadMask
        , Monad (MarionetteT m)
Monad (MarionetteT m) =>
(forall a. IO a -> MarionetteT m a) -> MonadIO (MarionetteT m)
forall a. IO a -> MarionetteT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (MarionetteT m)
forall (m :: * -> *) a. MonadIO m => IO a -> MarionetteT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> MarionetteT m a
liftIO :: forall a. IO a -> MarionetteT m a
MonadIO
        , MonadIO (MarionetteT m)
MonadIO (MarionetteT m) =>
(forall b.
 ((forall a. MarionetteT m a -> IO a) -> IO b) -> MarionetteT m b)
-> MonadUnliftIO (MarionetteT m)
forall b.
((forall a. MarionetteT m a -> IO a) -> IO b) -> MarionetteT m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
forall (m :: * -> *). MonadUnliftIO m => MonadIO (MarionetteT m)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. MarionetteT m a -> IO a) -> IO b) -> MarionetteT m b
$cwithRunInIO :: forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. MarionetteT m a -> IO a) -> IO b) -> MarionetteT m b
withRunInIO :: forall b.
((forall a. MarionetteT m a -> IO a) -> IO b) -> MarionetteT m b
MonadUnliftIO
        , MonadReader (TQueue CommandWithCallback)
        )

instance (MonadUnliftIO m, MonadThrow m, MonadCatch m) => Marionette (MarionetteT m) where
    sendCommand :: (HasCallStack, FromJSON a) => Command -> MarionetteT m a
    sendCommand :: forall a. (HasCallStack, FromJSON a) => Command -> MarionetteT m a
sendCommand Command
command = do
        TQueue CommandWithCallback
q <- MarionetteT m (TQueue CommandWithCallback)
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
        TMVar Result
result <- MarionetteT m (TMVar Result)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
        STM () -> MarionetteT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> MarionetteT m ())
-> (CommandWithCallback -> STM ())
-> CommandWithCallback
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue CommandWithCallback -> CommandWithCallback -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue CommandWithCallback
q (CommandWithCallback -> MarionetteT m ())
-> CommandWithCallback -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ Command -> TMVar Result -> CommandWithCallback
CommandWithCallback Command
command TMVar Result
result
        (Error -> MarionetteT m a)
-> (a -> MarionetteT m a) -> Either Error a -> MarionetteT m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> MarionetteT m a
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM a -> MarionetteT m a
forall a. a -> MarionetteT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> MarionetteT m a)
-> MarionetteT m (Either Error a) -> MarionetteT m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Result -> MarionetteT m (Either Error a)
forall a. FromJSON a => Result -> MarionetteT m (Either Error a)
parseResult (Result -> MarionetteT m (Either Error a))
-> MarionetteT m Result -> MarionetteT m (Either Error a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM Result -> MarionetteT m Result
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar Result -> STM Result
forall a. TMVar a -> STM a
readTMVar TMVar Result
result)
      where
        parseResult :: (FromJSON a) => Result -> MarionetteT m (Either Error a)
        parseResult :: forall a. FromJSON a => Result -> MarionetteT m (Either Error a)
parseResult =
            (Error -> MarionetteT m (Either Error a))
-> (Value -> MarionetteT m (Either Error a))
-> Result
-> MarionetteT m (Either Error a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Error a -> MarionetteT m (Either Error a)
forall a. a -> MarionetteT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> MarionetteT m (Either Error a))
-> (Error -> Either Error a)
-> Error
-> MarionetteT m (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error a
forall a b. a -> Either a b
Left) ((Value -> MarionetteT m (Either Error a))
 -> Result -> MarionetteT m (Either Error a))
-> (Value -> MarionetteT m (Either Error a))
-> Result
-> MarionetteT m (Either Error a)
forall a b. (a -> b) -> a -> b
$
                (String -> MarionetteT m (Either Error a))
-> (a -> MarionetteT m (Either Error a))
-> Either String a
-> MarionetteT m (Either Error a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AesonException -> MarionetteT m (Either Error a)
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (AesonException -> MarionetteT m (Either Error a))
-> (String -> AesonException)
-> String
-> MarionetteT m (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AesonException
AesonException) (Either Error a -> MarionetteT m (Either Error a)
forall a. a -> MarionetteT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error a -> MarionetteT m (Either Error a))
-> (a -> Either Error a) -> a -> MarionetteT m (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either Error a
forall a b. b -> Either a b
Right)
                    (Either String a -> MarionetteT m (Either Error a))
-> (Value -> Either String a)
-> Value
-> MarionetteT m (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON

instance (MonadThrow m, MonadCatch m) => MonadError Error (MarionetteT m) where
    throwError :: forall a. Error -> MarionetteT m a
throwError = Error -> MarionetteT m a
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM
    catchError :: forall a.
MarionetteT m a -> (Error -> MarionetteT m a) -> MarionetteT m a
catchError = MarionetteT m a -> (Error -> MarionetteT m a) -> MarionetteT m a
forall e a.
(HasCallStack, Exception e) =>
MarionetteT m a -> (e -> MarionetteT m a) -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch

-- | Connect to a Marionette server listening on @localhost:2828@ (started
-- by launching Firefox with the @--marionette@ flag), and run the given
-- action against it.
runMarionetteT
    :: forall m a
     . (MonadUnliftIO m, MonadMask m)
    => MarionetteT m a
    -> m a
runMarionetteT :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadMask m) =>
MarionetteT m a -> m a
runMarionetteT MarionetteT m a
action = do
    TQueue CommandWithCallback
sendQueue :: TQueue CommandWithCallback <- m (TQueue CommandWithCallback)
forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO
    TVar (IntMap (TMVar Result))
pendingCommands <- IntMap (TMVar Result) -> m (TVar (IntMap (TMVar Result)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO IntMap (TMVar Result)
forall a. Monoid a => a
mempty
    TMVar ()
done <- m (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
    let repeatUntilDone :: forall m'. (MonadIO m') => m' () -> m' ()
        repeatUntilDone :: forall (m' :: * -> *). MonadIO m' => m' () -> m' ()
repeatUntilDone m' ()
a =
            STM Bool -> m' Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar ()
done) m' Bool -> (Bool -> m' ()) -> m' ()
forall a b. m' a -> (a -> m' b) -> m' b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
False -> () -> m' ()
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Bool
True -> m' ()
a m' () -> m' () -> m' ()
forall a b. m' a -> m' b -> m' b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m' () -> m' ()
forall (m' :: * -> *). MonadIO m' => m' () -> m' ()
repeatUntilDone m' ()
a
        handleIncoming :: MarionetteMessage -> MarionetteT m ()
        handleIncoming :: MarionetteMessage -> MarionetteT m ()
handleIncoming MarionetteMessage
message =
            MarionetteMessage -> MarionetteT m (Message Result)
forall (m' :: * -> *) a'.
(MonadThrow m', FromJSON a') =>
MarionetteMessage -> m' a'
decodeMarionetteM MarionetteMessage
message MarionetteT m (Message Result)
-> (Message Result -> MarionetteT m ()) -> MarionetteT m ()
forall a b.
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Message{Int
Result
messageId :: Int
messageContent :: Result
messageContent :: forall a. Message a -> a
messageId :: forall a. Message a -> Int
..} ->
                STM (Maybe (TMVar Result)) -> MarionetteT m (Maybe (TMVar Result))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically
                    ( TVar (IntMap (TMVar Result))
-> (IntMap (TMVar Result)
    -> (Maybe (TMVar Result), IntMap (TMVar Result)))
-> STM (Maybe (TMVar Result))
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (IntMap (TMVar Result))
pendingCommands ((IntMap (TMVar Result)
  -> (Maybe (TMVar Result), IntMap (TMVar Result)))
 -> STM (Maybe (TMVar Result)))
-> (IntMap (TMVar Result)
    -> (Maybe (TMVar Result), IntMap (TMVar Result)))
-> STM (Maybe (TMVar Result))
forall a b. (a -> b) -> a -> b
$
                        (Int -> TMVar Result -> Maybe (TMVar Result))
-> Int
-> IntMap (TMVar Result)
-> (Maybe (TMVar Result), IntMap (TMVar Result))
forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
IntMap.updateLookupWithKey (\Int
_ TMVar Result
_ -> Maybe (TMVar Result)
forall a. Maybe a
Nothing) Int
messageId
                    )
                    MarionetteT m (Maybe (TMVar Result))
-> (Maybe (TMVar Result) -> MarionetteT m ()) -> MarionetteT m ()
forall a b.
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Maybe (TMVar Result)
Nothing -> UnexpectedResult -> MarionetteT m ()
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (UnexpectedResult -> MarionetteT m ())
-> (Result -> UnexpectedResult) -> Result -> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> UnexpectedResult
UnexpectedResult (Result -> MarionetteT m ()) -> Result -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ Result
messageContent
                        Just TMVar Result
result -> STM () -> MarionetteT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> MarionetteT m ()) -> STM () -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ TMVar Result -> Result -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Result
result Result
messageContent
        handleCommand :: Socket -> Int -> CommandWithCallback -> MarionetteT m ()
        handleCommand :: Socket -> Int -> CommandWithCallback -> MarionetteT m ()
handleCommand Socket
socket Int
messageId (CommandWithCallback Command
messageContent TMVar Result
callback) = do
            let message :: MarionetteMessage
message = LazyByteString -> MarionetteMessage
MarionetteMessage (LazyByteString -> MarionetteMessage)
-> (Message Command -> LazyByteString)
-> Message Command
-> MarionetteMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message Command -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode (Message Command -> MarionetteMessage)
-> Message Command -> MarionetteMessage
forall a b. (a -> b) -> a -> b
$ Message{Int
Command
messageContent :: Command
messageId :: Int
messageId :: Int
messageContent :: Command
..}
            IO () -> MarionetteT m ()
forall a. IO a -> MarionetteT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MarionetteT m ())
-> (MarionetteMessage -> IO ())
-> MarionetteMessage
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> LazyByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> LazyByteString -> m ()
sendLazy Socket
socket (LazyByteString -> IO ())
-> (MarionetteMessage -> LazyByteString)
-> MarionetteMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteMessage -> LazyByteString
forall a. Binary a => a -> LazyByteString
Binary.encode (MarionetteMessage -> MarionetteT m ())
-> MarionetteMessage -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ MarionetteMessage
message
            MarionetteT m () -> MarionetteT m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO do
                Maybe Result
result <- IO (Maybe Result) -> MarionetteT m (Maybe Result)
forall a. IO a -> MarionetteT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Result) -> MarionetteT m (Maybe Result))
-> (TMVar Result -> IO (Maybe Result))
-> TMVar Result
-> MarionetteT m (Maybe Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
5_000_000 (IO Result -> IO (Maybe Result))
-> (TMVar Result -> IO Result) -> TMVar Result -> IO (Maybe Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Result -> IO Result
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Result -> IO Result)
-> (TMVar Result -> STM Result) -> TMVar Result -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Result -> STM Result
forall a. TMVar a -> STM a
readTMVar (TMVar Result -> MarionetteT m (Maybe Result))
-> TMVar Result -> MarionetteT m (Maybe Result)
forall a b. (a -> b) -> a -> b
$ TMVar Result
callback
                Bool -> MarionetteT m () -> MarionetteT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Result -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Result
result) (MarionetteT m () -> MarionetteT m ())
-> (MarionetteMessage -> MarionetteT m ())
-> MarionetteMessage
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteTimeout -> MarionetteT m ()
forall e a. (HasCallStack, Exception e) => e -> MarionetteT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (MarionetteTimeout -> MarionetteT m ())
-> (MarionetteMessage -> MarionetteTimeout)
-> MarionetteMessage
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteMessage -> MarionetteTimeout
MarionetteTimeout (MarionetteMessage -> MarionetteT m ())
-> MarionetteMessage -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ MarionetteMessage
message
            STM () -> MarionetteT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> MarionetteT m ())
-> ((IntMap (TMVar Result) -> IntMap (TMVar Result)) -> STM ())
-> (IntMap (TMVar Result) -> IntMap (TMVar Result))
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (IntMap (TMVar Result))
-> (IntMap (TMVar Result) -> IntMap (TMVar Result)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (IntMap (TMVar Result))
pendingCommands ((IntMap (TMVar Result) -> IntMap (TMVar Result))
 -> MarionetteT m ())
-> (IntMap (TMVar Result) -> IntMap (TMVar Result))
-> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$
                Int
-> TMVar Result -> IntMap (TMVar Result) -> IntMap (TMVar Result)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
messageId TMVar Result
callback
        runSocket :: MarionetteT m ()
        runSocket :: MarionetteT m ()
runSocket =
            String
-> String
-> ((Socket, SockAddr) -> MarionetteT m ())
-> MarionetteT m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> ((Socket, SockAddr) -> m a) -> m a
connect String
"localhost" String
"2828" \(Socket
socket, SockAddr
_) -> do
                TQueue MarionetteMessage
incomingQueue <- Socket -> MarionetteT m (TQueue MarionetteMessage)
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadThrow m, Binary a) =>
Socket -> m (TQueue a)
incoming Socket
socket
                MarionetteT m Greeting -> MarionetteT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MarionetteT m Greeting -> MarionetteT m ())
-> (MarionetteMessage -> MarionetteT m Greeting)
-> MarionetteMessage
-> MarionetteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m' :: * -> *) a'.
(MonadThrow m', FromJSON a') =>
MarionetteMessage -> m' a'
decodeMarionetteM @_ @Greeting (MarionetteMessage -> MarionetteT m ())
-> MarionetteT m MarionetteMessage -> MarionetteT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM MarionetteMessage -> MarionetteT m MarionetteMessage
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue MarionetteMessage -> STM MarionetteMessage
forall a. TQueue a -> STM a
readTQueue TQueue MarionetteMessage
incomingQueue)
                let send :: Int -> MarionetteT m ()
send Int
messageId =
                        STM (Maybe CommandWithCallback)
-> MarionetteT m (Maybe CommandWithCallback)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically
                            ( TMVar () -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar ()
done STM Bool
-> (Bool -> STM (Maybe CommandWithCallback))
-> STM (Maybe CommandWithCallback)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                Bool
True -> CommandWithCallback -> Maybe CommandWithCallback
forall a. a -> Maybe a
Just (CommandWithCallback -> Maybe CommandWithCallback)
-> STM CommandWithCallback -> STM (Maybe CommandWithCallback)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue CommandWithCallback -> STM CommandWithCallback
forall a. TQueue a -> STM a
readTQueue TQueue CommandWithCallback
sendQueue
                                Bool
False -> Maybe CommandWithCallback -> STM (Maybe CommandWithCallback)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CommandWithCallback
forall a. Maybe a
Nothing
                            )
                            MarionetteT m (Maybe CommandWithCallback)
-> (Maybe CommandWithCallback -> MarionetteT m ())
-> MarionetteT m ()
forall a b.
MarionetteT m a -> (a -> MarionetteT m b) -> MarionetteT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                Maybe CommandWithCallback
Nothing -> () -> MarionetteT m ()
forall a. a -> MarionetteT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                                Just CommandWithCallback
command -> do
                                    Socket -> Int -> CommandWithCallback -> MarionetteT m ()
handleCommand Socket
socket Int
messageId CommandWithCallback
command
                                    Int -> MarionetteT m ()
send (Int -> MarionetteT m ()) -> Int -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ Int
messageId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                MarionetteT m () -> MarionetteT m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (MarionetteT m () -> MarionetteT m ThreadId)
-> MarionetteT m () -> MarionetteT m ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> MarionetteT m ()
send Int
1
                MarionetteT m () -> MarionetteT m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (MarionetteT m () -> MarionetteT m ThreadId)
-> (MarionetteT m () -> MarionetteT m ())
-> MarionetteT m ()
-> MarionetteT m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteT m () -> MarionetteT m ()
forall (m' :: * -> *). MonadIO m' => m' () -> m' ()
repeatUntilDone (MarionetteT m () -> MarionetteT m ThreadId)
-> MarionetteT m () -> MarionetteT m ThreadId
forall a b. (a -> b) -> a -> b
$ MarionetteMessage -> MarionetteT m ()
handleIncoming (MarionetteMessage -> MarionetteT m ())
-> MarionetteT m MarionetteMessage -> MarionetteT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM MarionetteMessage -> MarionetteT m MarionetteMessage
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TQueue MarionetteMessage -> STM MarionetteMessage
forall a. TQueue a -> STM a
readTQueue TQueue MarionetteMessage
incomingQueue)
                STM () -> MarionetteT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> MarionetteT m ()) -> STM () -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar TMVar ()
done
    (ReaderT (TQueue CommandWithCallback) m a
 -> TQueue CommandWithCallback -> m a)
-> TQueue CommandWithCallback
-> ReaderT (TQueue CommandWithCallback) m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (TQueue CommandWithCallback) m a
-> TQueue CommandWithCallback -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TQueue CommandWithCallback
sendQueue (ReaderT (TQueue CommandWithCallback) m a -> m a)
-> (MarionetteT m a -> ReaderT (TQueue CommandWithCallback) m a)
-> MarionetteT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(MarionetteT ReaderT (TQueue CommandWithCallback) m a
r) -> ReaderT (TQueue CommandWithCallback) m a
r) (MarionetteT m a -> m a) -> MarionetteT m a -> m a
forall a b. (a -> b) -> a -> b
$ do
        MarionetteT m () -> MarionetteT m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO MarionetteT m ()
runSocket
        a
a <- MarionetteT m a
action
        STM () -> MarionetteT m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> MarionetteT m ()) -> STM () -> MarionetteT m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
done ()
        pure a
a
  where
    decodeMarionetteM :: forall m' a'. (MonadThrow m', FromJSON a') => MarionetteMessage -> m' a'
    decodeMarionetteM :: forall (m' :: * -> *) a'.
(MonadThrow m', FromJSON a') =>
MarionetteMessage -> m' a'
decodeMarionetteM = (String -> m' a') -> (a' -> m' a') -> Either String a' -> m' a'
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AssertionFailed -> m' a'
forall e a. (HasCallStack, Exception e) => e -> m' a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (AssertionFailed -> m' a')
-> (String -> AssertionFailed) -> String -> m' a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AssertionFailed
AssertionFailed) a' -> m' a'
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a' -> m' a')
-> (MarionetteMessage -> Either String a')
-> MarionetteMessage
-> m' a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteMessage -> Either String a'
forall a'. FromJSON a' => MarionetteMessage -> Either String a'
decodeMarionette

    decodeMarionette :: forall a'. (FromJSON a') => MarionetteMessage -> Either String a'
    decodeMarionette :: forall a'. FromJSON a' => MarionetteMessage -> Either String a'
decodeMarionette (MarionetteMessage LazyByteString
lbs) = LazyByteString -> Either String a'
forall a. FromJSON a => LazyByteString -> Either String a
Aeson.eitherDecode LazyByteString
lbs