Main.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

module Book3.Main where

import Book3.Peer
import Book3.Protocol
import Book3.Type
import Control.Carrier.Lift (runM, sendM)
import Control.Carrier.Random.Gen (runRandom)
import Control.Concurrent.Class.MonadSTM
import Control.Monad
import Control.Monad.Class.MonadFork (MonadFork, forkIO)
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadThrow (MonadThrow)
import Control.Monad.Class.MonadTimer (MonadDelay)
import Control.Monad.IOSim
import System.Random (StdGen, split)
import TypedSession.Codec
import TypedSession.Core
import TypedSession.Driver

mvarsAsChannel
  :: (MonadSTM m)
  => TMVar m a
  -> TMVar m a
  -> Channel m a
mvarsAsChannel bufferRead bufferWrite =
  Channel{send, recv}
 where
  send x = atomically (putTMVar bufferWrite x)
  recv = atomically (Just <$> takeTMVar bufferRead)

myTracer :: (MonadSay m) => String -> Tracer BookRole Book m
myTracer st v = say (st <> show v)

runAll
  :: forall n
   . ( Monad n
     , MonadSTM n
     , MonadSay n
     , MonadThrow n
     , MonadFork n
     , MonadDelay n
     )
  => StdGen
  -> n ()
runAll g = do
  buyerTMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book)
  buyer2TMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book)
  sellerTMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book)

  buyerDriver <-
    driverSimple
      (myTracer "buyer :")
      encodeMsg
      (Decode decodeMsg)
      [ (SomeRole SSeller, mvarsAsChannel buyerTMVar sellerTMVar)
      , (SomeRole SBuyer2, mvarsAsChannel buyerTMVar buyer2TMVar)
      ]
      sendM

  buyer2Driver <-
    driverSimple
      (myTracer "buyer2 :")
      encodeMsg
      (Decode decodeMsg)
      [(SomeRole SBuyer, mvarsAsChannel buyer2TMVar buyerTMVar)]
      sendM

  sellerDriver <-
    driverSimple
      (myTracer "seller :")
      encodeMsg
      (Decode decodeMsg)
      [(SomeRole SBuyer, mvarsAsChannel sellerTMVar buyerTMVar)]
      sendM

  let (g0, g1) = split g
      (g2, g3) = split g0

  resultTMVar1 <- newEmptyTMVarIO
  resultTMVar2 <- newEmptyTMVarIO

  -- fork seller Peer thread
  forkIO $ do
    runM $ runRandom g1 $ runPeerWithDriver sellerDriver sellerPeer
    atomically $ writeTMVar resultTMVar1 ()

  -- fork buyer2 Peer thread
  forkIO $ do
    runM $ runRandom g2 $ runPeerWithDriver buyer2Driver buyer2Peer
    atomically $ writeTMVar resultTMVar2 ()

  -- run buyer Peer
  void $ runM $ runRandom g3 $ runPeerWithDriver buyerDriver buyerPeer

  -- wait seller, buyer
  atomically $ do
    takeTMVar resultTMVar1
    takeTMVar resultTMVar2

book3Prop :: StdGen -> Either Failure ()
book3Prop v = runSim (runAll v)