module Hydra.FireForgetSpec where

import Hydra.Prelude

import Control.Concurrent.Class.MonadSTM (newTVarIO, readTVarIO, writeTVar)
import Control.Tracer (nullTracer)
import Hydra.Network.Ouroboros.Client (FireForgetClient (..), fireForgetClientPeer)
import Hydra.Network.Ouroboros.Codec (codecFireForget)
import Hydra.Network.Ouroboros.Server (FireForgetServer (..), fireForgetServerPeer)
import Network.TypedProtocol.Channel (createConnectedChannels)
import Network.TypedProtocol.Driver.Simple (runPeer)
import Test.Hspec.Core.Spec
import Test.Util (shouldBe, shouldRunInSim)

spec :: Spec
spec :: Spec
spec =
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"client can send 'Hail Hydra!' to server" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    ((Text
res, Maybe LByteString
_), ((), Maybe LByteString)
_) <- (forall s.
 IOSim s ((Text, Maybe LByteString), ((), Maybe LByteString)))
-> IO ((Text, Maybe LByteString), ((), Maybe LByteString))
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s.
  IOSim s ((Text, Maybe LByteString), ((), Maybe LByteString)))
 -> IO ((Text, Maybe LByteString), ((), Maybe LByteString)))
-> (forall s.
    IOSim s ((Text, Maybe LByteString), ((), Maybe LByteString)))
-> IO ((Text, Maybe LByteString), ((), Maybe LByteString))
forall a b. (a -> b) -> a -> b
$ do
      (Channel (IOSim s) LByteString
channelA, Channel (IOSim s) LByteString
channelB) <- IOSim
  s (Channel (IOSim s) LByteString, Channel (IOSim s) LByteString)
forall (m :: * -> *) a.
(MonadLabelledSTM m, MonadTraceSTM m, Show a) =>
m (Channel m a, Channel m a)
createConnectedChannels
      FireForgetServer Text (IOSim s) Text
server <- IOSim s (FireForgetServer Text (IOSim s) Text)
forall (m :: * -> *).
MonadSTM m =>
m (FireForgetServer Text m Text)
newServer
      IOSim s (Text, Maybe LByteString)
-> IOSim s ((), Maybe LByteString)
-> IOSim s ((Text, Maybe LByteString), ((), Maybe LByteString))
forall a b. IOSim s a -> IOSim s b -> IOSim s (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
concurrently
        (Tracer (IOSim s) (TraceSendRecv (FireForget Text))
-> Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
-> Channel (IOSim s) LByteString
-> Peer
     (FireForget Text) 'AsServer 'NonPipelined 'StIdle (IOSim s) Text
-> IOSim s (Text, Maybe LByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer (IOSim s) (TraceSendRecv (FireForget Text))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
forall (m :: * -> *) msg.
(MonadST m, FromCBOR msg, ToCBOR msg) =>
Codec (FireForget msg) DeserialiseFailure m LByteString
codecFireForget Channel (IOSim s) LByteString
channelA (Peer
   (FireForget Text) 'AsServer 'NonPipelined 'StIdle (IOSim s) Text
 -> IOSim s (Text, Maybe LByteString))
-> Peer
     (FireForget Text) 'AsServer 'NonPipelined 'StIdle (IOSim s) Text
-> IOSim s (Text, Maybe LByteString)
forall a b. (a -> b) -> a -> b
$ FireForgetServer Text (IOSim s) Text
-> Peer
     (FireForget Text) 'AsServer 'NonPipelined 'StIdle (IOSim s) Text
forall (m :: * -> *) msg a.
Monad m =>
FireForgetServer msg m a
-> Peer (FireForget msg) 'AsServer 'NonPipelined 'StIdle m a
fireForgetServerPeer FireForgetServer Text (IOSim s) Text
server)
        (Tracer (IOSim s) (TraceSendRecv (FireForget Text))
-> Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
-> Channel (IOSim s) LByteString
-> Peer
     (FireForget Text) 'AsClient 'NonPipelined 'StIdle (IOSim s) ()
-> IOSim s ((), Maybe LByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer (IOSim s) (TraceSendRecv (FireForget Text))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
forall (m :: * -> *) msg.
(MonadST m, FromCBOR msg, ToCBOR msg) =>
Codec (FireForget msg) DeserialiseFailure m LByteString
codecFireForget Channel (IOSim s) LByteString
channelB (Peer
   (FireForget Text) 'AsClient 'NonPipelined 'StIdle (IOSim s) ()
 -> IOSim s ((), Maybe LByteString))
-> Peer
     (FireForget Text) 'AsClient 'NonPipelined 'StIdle (IOSim s) ()
-> IOSim s ((), Maybe LByteString)
forall a b. (a -> b) -> a -> b
$ FireForgetClient Text (IOSim s) ()
-> Peer
     (FireForget Text) 'AsClient 'NonPipelined 'StIdle (IOSim s) ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetClient msg m a
-> Peer (FireForget msg) 'AsClient 'NonPipelined 'StIdle m a
fireForgetClientPeer FireForgetClient Text (IOSim s) ()
forall (m :: * -> *). Applicative m => FireForgetClient Text m ()
client)
    Text
res Text -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` Text
"Hail Hydra!"

client :: Applicative m => FireForgetClient Text m ()
client :: forall (m :: * -> *). Applicative m => FireForgetClient Text m ()
client =
  Text
-> m (FireForgetClient Text m ()) -> FireForgetClient Text m ()
forall msg (m :: * -> *) a.
msg -> m (FireForgetClient msg m a) -> FireForgetClient msg m a
SendMsg (Text
"Hail Hydra!" :: Text) (m (FireForgetClient Text m ()) -> FireForgetClient Text m ())
-> m (FireForgetClient Text m ()) -> FireForgetClient Text m ()
forall a b. (a -> b) -> a -> b
$ FireForgetClient Text m () -> m (FireForgetClient Text m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FireForgetClient Text m () -> m (FireForgetClient Text m ()))
-> FireForgetClient Text m () -> m (FireForgetClient Text m ())
forall a b. (a -> b) -> a -> b
$ m () -> FireForgetClient Text m ()
forall (m :: * -> *) a msg. m a -> FireForgetClient msg m a
SendDone (m () -> FireForgetClient Text m ())
-> m () -> FireForgetClient Text m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

newServer :: forall m. MonadSTM m => m (FireForgetServer Text m Text)
newServer :: forall (m :: * -> *).
MonadSTM m =>
m (FireForgetServer Text m Text)
newServer = do
  TVar m Text
tvar <- Text -> m (TVar m Text)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Text
""
  FireForgetServer Text m Text -> m (FireForgetServer Text m Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FireForgetServer Text m Text -> m (FireForgetServer Text m Text))
-> FireForgetServer Text m Text -> m (FireForgetServer Text m Text)
forall a b. (a -> b) -> a -> b
$ TVar m Text -> FireForgetServer Text m Text
server TVar m Text
tvar
 where
  server :: TVar m Text -> FireForgetServer Text m Text
  server :: TVar m Text -> FireForgetServer Text m Text
server TVar m Text
tvar =
    FireForgetServer
      { $sel:recvMsg:FireForgetServer :: Text -> m (FireForgetServer Text m Text)
recvMsg = \Text
msg -> do
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m Text -> Text -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Text
tvar Text
msg)
          FireForgetServer Text m Text -> m (FireForgetServer Text m Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar m Text -> FireForgetServer Text m Text
server TVar m Text
tvar)
      , $sel:recvMsgDone:FireForgetServer :: m Text
recvMsgDone =
          TVar m Text -> m Text
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m Text
tvar
      }