symbiote 0.0.3 → 0.0.4
raw patch · 2 files changed
+65/−20 lines, 2 files
Files
- src/Test/Serialization/Symbiote/ZeroMQ.hs +63/−18
- symbiote.cabal +2/−2
src/Test/Serialization/Symbiote/ZeroMQ.hs view
@@ -28,6 +28,7 @@ import qualified Data.Serialize as Cereal import Data.List.NonEmpty (NonEmpty (..)) import Data.Singleton.Class (Extractable)+import Data.Restricted (Restricted) import Control.Monad (forever, void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Control.Aligned (MonadBaseControl, liftBaseWith)@@ -39,16 +40,17 @@ import Control.Concurrent.STM.TChan.Typed (TChanRW, newTChanRW, writeTChanRW, readTChanRW) import Control.Concurrent.Threaded.Hash (threaded) import System.ZMQ4 (Router (..), Dealer (..), Pair (..))-import System.ZMQ4.Monadic (runZMQ, async)-import System.ZMQ4.Simple (ZMQIdent, socket, bind, send, receive, connect, setUUIDIdentity)+import System.ZMQ4.Monadic (runZMQ, async, KeyFormat, setCurveServer, setCurvePublicKey, setCurveSecretKey, setCurveServerKey)+import System.ZMQ4.Simple (ZMQIdent, socket, bind, send, receive, connect, setUUIDIdentity, Socket (..)) import System.Timeout (timeout)+import Unsafe.Coerce (unsafeCoerce) secondPeerZeroMQ :: MonadIO m => MonadBaseControl IO m stM => Extractable stM- => ZeroMQParams+ => ZeroMQParams f -> Debug -> SymbioteT BS.ByteString m () -- ^ Tests registered -> m ()@@ -57,33 +59,52 @@ firstPeerZeroMQ :: MonadIO m => MonadBaseControl IO m stM => Extractable stM- => ZeroMQParams+ => ZeroMQParams f -> Debug -> SymbioteT BS.ByteString m () -- ^ Tests registered -> m () firstPeerZeroMQ params debug = peerZeroMQ params debug firstPeer +-- | Parameterized by optional keypairs associated with CurveMQ+data ZeroMQServerOrClient f+ = ZeroMQServer (Maybe (ServerKeys f))+ | ZeroMQClient (Maybe (ClientKeys f)) -data ZeroMQServerOrClient- = ZeroMQServer- | ZeroMQClient+data Key f = Key+ { format :: KeyFormat f -- ^ Text via Z85 or raw binary+ , key :: Restricted f BS.ByteString+ } -data ZeroMQParams = ZeroMQParams+data KeyPair f = KeyPair+ { public :: Key f+ , secret :: Key f+ }++newtype ServerKeys f = ServerKeys+ { serverKeyPair :: KeyPair f+ }++data ClientKeys f = ClientKeys+ { clientKeyPair :: KeyPair f+ , clientServer :: Key f -- ^ The public key of the server+ }++data ZeroMQParams f = ZeroMQParams { zmqHost :: String- , zmqServerOrClient :: ZeroMQServerOrClient+ , zmqServerOrClient :: ZeroMQServerOrClient f , zmqNetwork :: Network } -- | ZeroMQ can only work on 'BS.ByteString's-peerZeroMQ :: forall m stM them me+peerZeroMQ :: forall m stM them me f . MonadIO m => MonadBaseControl IO m stM => Extractable stM => Show (them BS.ByteString) => Cereal.Serialize (me BS.ByteString) => Cereal.Serialize (them BS.ByteString)- => ZeroMQParams+ => ZeroMQParams f -> Debug -> ( (me BS.ByteString -> m ()) -> m (them BS.ByteString)@@ -97,7 +118,7 @@ -> m () peerZeroMQ (ZeroMQParams host clientOrServer network) debug peer tests = case (network,clientOrServer) of- (Public,ZeroMQServer) -> do+ (Public, ZeroMQServer mKeys) -> do (incoming :: TChanRW 'Write (ZMQIdent, them BS.ByteString)) <- writeOnly <$> liftIO (atomically newTChanRW) -- the process that gets invoked for each new thread. Writes to a @me BS.ByteString@ and reads from a @them BS.ByteString@. let process :: TChanRW 'Read (them BS.ByteString) -> TChanRW 'Write (me BS.ByteString) -> m ()@@ -123,7 +144,12 @@ -- forever bind to ZeroMQ runZMQ $ do- s <- socket Router Dealer+ s@(Socket s') <- socket Router Dealer+ case mKeys of+ Nothing -> pure ()+ Just (ServerKeys (KeyPair _ (Key secFormat secKey))) -> do+ setCurveServer True s'+ setCurveSecretKey secFormat secKey s' bind s host -- sending loop (separate thread)@@ -177,7 +203,15 @@ zThread <- case network of -- is a ZeroMQClient Public -> runZMQ $ async $ do- s <- socket Dealer Router+ s@(Socket s') <- socket Dealer Router+ case clientOrServer of+ ZeroMQClient mKeys -> case mKeys of+ Nothing -> pure ()+ Just (ClientKeys (KeyPair (Key pubFormat pubKey) (Key secFormat secKey)) (Key servFormat server)) -> do+ setCurvePublicKey pubFormat pubKey s'+ setCurveSecretKey secFormat secKey s'+ setCurveServerKey servFormat server s'+ _ -> error "impossible case" setUUIDIdentity s connect s host @@ -185,15 +219,26 @@ receivingLoop s Private -> case clientOrServer of- ZeroMQServer -> runZMQ $ async $ do- s <- socket Pair Pair+ ZeroMQServer mKeys -> runZMQ $ async $ do+ s@(Socket s') <- socket Pair Pair+ case mKeys of+ Nothing -> pure ()+ Just (ServerKeys (KeyPair _ (Key secFormat secKey))) -> do+ setCurveServer True s'+ setCurveSecretKey secFormat secKey s' bind s host sendingThread s receivingLoop s- ZeroMQClient -> runZMQ $ async $ do- s <- socket Pair Pair+ ZeroMQClient mKeys -> runZMQ $ async $ do+ s@(Socket s') <- socket Pair Pair+ case mKeys of+ Nothing -> pure ()+ Just (ClientKeys (KeyPair (Key pubFormat pubKey) (Key secFormat secKey)) (Key servFormat server)) -> do+ setCurvePublicKey pubFormat pubKey s'+ setCurveSecretKey secFormat secKey s'+ setCurveServerKey servFormat server s' connect s host sendingThread s
symbiote.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: bb816980e733fd1d164875e94302b3003d655cc593b1de79483b12e50a73761b+-- hash: b0ed7398ea9c3fdf50a9dfc395712f17935161fec68786977d951a94aacb8142 name: symbiote-version: 0.0.3+version: 0.0.4 synopsis: Data serialization, communication, and operation verification implementation description: Please see the README on GitHub at <https://github.com/athanclark/symbiote#readme> category: Data, Testing