mirror of https://github.com/voidlizard/hbs2
118 lines
3.2 KiB
Haskell
118 lines
3.2 KiB
Haskell
{-# Language TemplateHaskell #-}
|
|
module Main where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Clock
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Messaging.Unix
|
|
import HBS2.Actors.Peer
|
|
import HBS2.OrDie
|
|
|
|
import Codec.Serialise
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Resource
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Lens.Micro.Platform
|
|
import Prettyprinter
|
|
import System.FilePath.Posix
|
|
import System.IO
|
|
import System.IO.Temp
|
|
import UnliftIO.Async
|
|
|
|
|
|
debug :: (MonadIO m) => Doc ann -> m ()
|
|
debug p = liftIO $ hPrint stderr p
|
|
|
|
|
|
data PingPong e = Ping Int
|
|
| Pong Int
|
|
deriving stock (Eq,Generic,Show,Read)
|
|
|
|
|
|
instance Serialise (PingPong e)
|
|
|
|
|
|
instance HasProtocol UNIX (PingPong UNIX) where
|
|
type instance ProtocolId (PingPong UNIX) = 1
|
|
type instance Encoded UNIX = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
pingPongHandler :: forall e m . ( MonadIO m
|
|
, Response e (PingPong e) m
|
|
, HasProtocol e (PingPong e)
|
|
)
|
|
=> Int
|
|
-> PingPong e
|
|
-> m ()
|
|
|
|
pingPongHandler n = \case
|
|
|
|
Ping c -> debug ("Ping" <+> pretty c) >> response (Pong @e c)
|
|
|
|
Pong c | c < n -> debug ("Pong" <+> pretty c) >> response (Ping @e (succ c))
|
|
| otherwise -> pure ()
|
|
|
|
data PPEnv =
|
|
PPEnv
|
|
{ _ppSelf :: Peer UNIX
|
|
, _ppFab :: Fabriq UNIX
|
|
}
|
|
|
|
makeLenses 'PPEnv
|
|
|
|
newtype PingPongM m a = PingPongM { fromPingPong :: ReaderT PPEnv m a }
|
|
deriving newtype ( Functor
|
|
, Applicative
|
|
, Monad
|
|
, MonadIO
|
|
, MonadReader PPEnv
|
|
, MonadTrans
|
|
)
|
|
|
|
runPingPong :: (MonadIO m, PeerMessaging UNIX) => MessagingUnix -> PingPongM m a -> m a
|
|
runPingPong tran m = runReaderT (fromPingPong m) (PPEnv (msgUnixSelf tran) (Fabriq tran))
|
|
|
|
instance Monad m => HasFabriq UNIX (PingPongM m) where
|
|
getFabriq = asks (view ppFab)
|
|
|
|
instance Monad m => HasOwnPeer UNIX (PingPongM m) where
|
|
ownPeer = asks (view ppSelf)
|
|
|
|
instance HasTimeLimits UNIX (PingPong UNIX) IO where
|
|
tryLockForPeriod _ _ = pure True
|
|
|
|
main :: IO ()
|
|
main = do
|
|
liftIO $ hSetBuffering stdout LineBuffering
|
|
liftIO $ hSetBuffering stderr LineBuffering
|
|
|
|
withSystemTempDirectory "test-unix-socket" $ \tmp -> do
|
|
|
|
let soname = tmp </> "unix.socket"
|
|
|
|
server <- newMessagingUnix True 1.0 soname
|
|
|
|
client <- newMessagingUnix False 1.0 soname
|
|
|
|
m1 <- async $ runMessagingUnix server
|
|
m2 <- async $ runMessagingUnix client
|
|
|
|
p1 <- async $ runPingPong server do
|
|
runProto @UNIX
|
|
[ makeResponse (pingPongHandler 100000)
|
|
]
|
|
|
|
p2 <- async $ runPingPong client do
|
|
request (msgUnixSelf server) (Ping @UNIX 0)
|
|
runProto @UNIX
|
|
[ makeResponse (pingPongHandler 100000)
|
|
]
|
|
|
|
(_,r) <- liftIO $ waitAnyCatchCancel [m1,m2,p1,p2]
|
|
|
|
debug (viaShow r)
|
|
|
|
|
|
|