mirror of https://github.com/voidlizard/hbs2
148 lines
4.1 KiB
Haskell
148 lines
4.1 KiB
Haskell
{-# LANGUAGE ImportQualifiedPost #-}
|
|
|
|
-- May develop an run it with command:
|
|
-- ```
|
|
-- nix develop -c ghcid -c "cabal repl" hbs2-tests:test-unix-messaging -r=Main.main
|
|
-- ```
|
|
|
|
module Main where
|
|
|
|
import Codec.Serialise
|
|
import Control.Monad
|
|
import Control.Monad.Fix
|
|
import Control.Monad.Reader hiding (reader)
|
|
import Control.Monad.Trans.Cont
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Data.Hashable
|
|
import Data.Set (Set)
|
|
import Data.Set qualified as Set
|
|
import Data.String.Conversions (cs)
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding qualified as TE
|
|
import Data.Time
|
|
import Lens.Micro.Platform
|
|
import Network.Socket
|
|
import Network.Socket.ByteString hiding (sendTo)
|
|
import Network.Socket.ByteString.Lazy qualified as SL
|
|
import UnliftIO
|
|
import UnliftIO.Async
|
|
import UnliftIO.Concurrent
|
|
|
|
import HBS2.OrDie
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Merkle
|
|
import HBS2.Net.Messaging.Unix
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.Net.Proto.Service hiding (decode, encode)
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.System.Logger.Simple.ANSI
|
|
import HBS2.Storage
|
|
|
|
soname = "/tmp/hbs2-dev.sock"
|
|
|
|
data EchoH
|
|
|
|
type DevAPI = '[EchoH]
|
|
|
|
instance HasProtocol UNIX (ServiceProto DevAPI UNIX) where
|
|
type ProtocolId (ServiceProto DevAPI UNIX) = 0xDE50000
|
|
type Encoded UNIX = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
type instance Input EchoH = Text
|
|
type instance Output EchoH = Either Text Text
|
|
|
|
sayt :: (MonadIO m) => Text -> m ()
|
|
sayt = liftIO . BS8.putStrLn . TE.encodeUtf8
|
|
|
|
instance (MonadIO m) => HandleMethod m EchoH where
|
|
handleMethod msg = do
|
|
now <- liftIO getCurrentTime
|
|
-- threadDelay (10 ^ 5)
|
|
let resp = (cs . show) now <> " " <> msg
|
|
-- sayt $ "Got request: " <> resp
|
|
pure $ Right $ resp
|
|
|
|
instance
|
|
(MonadUnliftIO m)
|
|
=> HasDeferred (ServiceProto DevAPI UNIX) UNIX m
|
|
where
|
|
deferred m = void (async m)
|
|
|
|
withServer :: AnyProbe -> (() -> IO r) -> IO r
|
|
withServer p = runContT do
|
|
server <- newMessagingUnixOpts [] True 0.10 soname
|
|
setProbe server p
|
|
(link <=< ContT . withAsync) do
|
|
runMessagingUnix server
|
|
(link <=< ContT . withAsync) do
|
|
flip runReaderT server do
|
|
runProto @UNIX
|
|
[ makeResponse (makeServer @DevAPI)
|
|
]
|
|
|
|
withClient :: (ServiceCaller DevAPI UNIX -> IO r) -> IO r
|
|
withClient = runContT do
|
|
client <- newMessagingUnixOpts [] False 0.15 soname
|
|
(link <=< ContT . withAsync) do
|
|
runMessagingUnix client
|
|
caller <- makeServiceCaller @DevAPI @UNIX (fromString soname)
|
|
(link <=< ContT . withAsync) do
|
|
liftIO $ runReaderT (runServiceClient @DevAPI @UNIX caller) client
|
|
pure caller
|
|
|
|
main :: IO ()
|
|
main = do
|
|
|
|
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
|
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
|
setLogging @NOTICE $ toStdout . logPrefix ""
|
|
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
|
|
|
totfuck <- newTVarIO 0
|
|
|
|
p <- newSimpleProbe "MessagingUnix"
|
|
|
|
flip runContT pure do
|
|
void $ ContT (withServer p)
|
|
pause @'Seconds 1
|
|
s <- replicateM 16 $ lift $ async do
|
|
void $ flip runContT pure do
|
|
caller <- ContT withClient
|
|
tsucc <- newTVarIO 0
|
|
tfail <- newTVarIO 0
|
|
for_ [1..10000] $ \i -> do
|
|
lift (callRpcWaitMay @EchoH (TimeoutSec 2) caller ((cs . show) i))
|
|
>>= \case
|
|
Just (Right _) -> atomically $ modifyTVar tsucc succ
|
|
e -> atomically (modifyTVar tfail succ) >> err (viaShow e)
|
|
|
|
ok <- readTVarIO tsucc
|
|
fuck <- readTVarIO tfail
|
|
atomically $ modifyTVar totfuck (+fuck)
|
|
notice $ "Finished:" <+> "succeed" <+> pretty ok <+> "failed" <+> pretty fuck
|
|
|
|
pause @'Seconds 3
|
|
mapM_ wait s
|
|
|
|
tf <- readTVarIO totfuck
|
|
|
|
notice $ "total errors" <+> pretty tf
|
|
|
|
-- notice "waiting for metrics"
|
|
-- pause @'Seconds 10
|
|
-- s <- probeSnapshot [p]
|
|
-- liftIO $ print $ "probes" <> line <> vcat (fmap pretty s)
|
|
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
setLoggingOff @DEBUG
|
|
|
|
|