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.Server (FireForgetServer (..), fireForgetServerPeer)
import Hydra.Network.Ouroboros.Type (codecFireForget)
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, ()
_) <- (forall s. IOSim s (Text, ())) -> IO (Text, ())
forall a. (forall s. IOSim s a) -> IO a
shouldRunInSim ((forall s. IOSim s (Text, ())) -> IO (Text, ()))
-> (forall s. IOSim s (Text, ())) -> IO (Text, ())
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. MonadSTM m => 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 -> IOSim s () -> IOSim s (Text, ())
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 'StIdle (IOSim s) Text
-> IOSim s Text
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 st m a
-> m a
runPeer Tracer (IOSim s) (TraceSendRecv (FireForget Text))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m LByteString
codecFireForget Channel (IOSim s) LByteString
channelA (Peer (FireForget Text) 'AsServer 'StIdle (IOSim s) Text
 -> IOSim s Text)
-> Peer (FireForget Text) 'AsServer 'StIdle (IOSim s) Text
-> IOSim s Text
forall a b. (a -> b) -> a -> b
$ FireForgetServer Text (IOSim s) Text
-> Peer (FireForget Text) 'AsServer 'StIdle (IOSim s) Text
forall (m :: * -> *) msg a.
Monad m =>
FireForgetServer msg m a
-> Peer (FireForget msg) 'AsServer '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 'StIdle (IOSim s) ()
-> IOSim s ()
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 st m a
-> m a
runPeer Tracer (IOSim s) (TraceSendRecv (FireForget Text))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec (FireForget Text) DeserialiseFailure (IOSim s) LByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m LByteString
codecFireForget Channel (IOSim s) LByteString
channelB (Peer (FireForget Text) 'AsClient 'StIdle (IOSim s) ()
 -> IOSim s ())
-> Peer (FireForget Text) 'AsClient 'StIdle (IOSim s) ()
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ FireForgetClient Text (IOSim s) ()
-> Peer (FireForget Text) 'AsClient 'StIdle (IOSim s) ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetClient msg m a
-> Peer (FireForget msg) 'AsClient '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
      }