zre 0.1.0.1 → 0.1.0.2
raw patch · 22 files changed
+423/−99 lines, 22 filesdep +QuickCheckdep +directorydep +filepathdep −binary-strict
Dependencies added: QuickCheck, directory, filepath, network-bsd, quickcheck-instances
Dependencies removed: binary-strict
Files
- app/Main.hs +1/−1
- app/Match.hs +6/−23
- src/Data/ZGossip.hs +5/−8
- src/Data/ZMQParse.hs +43/−3
- src/Data/ZRE.hs +11/−14
- src/Network/ZGossip/ZMQ.hs +4/−4
- src/Network/ZRE.hs +26/−11
- src/Network/ZRE/Beacon.hs +2/−2
- src/Network/ZRE/Config.hs +24/−9
- src/Network/ZRE/Lib.hs +70/−0
- src/Network/ZRE/Options.hs +1/−0
- src/Network/ZRE/Peer.hs +6/−3
- src/Network/ZRE/Types.hs +15/−6
- src/Network/ZRE/ZMQ.hs +2/−2
- src/System/ZMQ4/Endpoint.hs +6/−5
- test/Arbitrary.hs +74/−0
- test/Binary.hs +32/−0
- test/Endpoint.hs +14/−0
- test/Spec.hs +19/−1
- test/ZGossip.hs +18/−0
- test/ZRE.hs +21/−0
- zre.cabal +23/−7
app/Main.hs view
@@ -55,7 +55,7 @@ repl = do q <- getApiQueue- liftIO $ evalRepl ">>> " (cmd q) [] (Word completer) ini+ liftIO $ evalRepl (pure ">>> ") (cmd q) [] Nothing (Word completer) ini liftIO $ atomically $ writeTBQueue q DoQuit cmd :: APIQueue -> String -> Repl ()
app/Match.hs view
@@ -29,28 +29,11 @@ app = do zjoin "a" zjoin "b"+ zjoin "c"+ zjoin "d" forever $ match [- handleGroup "a" echo- , handleGroup "b" rev+ isGroupMsg "a" ==> echo+ , isGroupMsg "b" ==> rev+ , iff (isGroupMsg "c") echo+ , decodeShouts (\x -> Right $ B.pack $ show x) (\x -> zshout "d" x) ]--isGroupMsg :: Group -> Event -> Bool-isGroupMsg group (Shout _uuid g _content _time) = g == group-isGroupMsg _ _ = False--handleGroup :: MonadPlus m => Group -> b -> Event -> m b-handleGroup group action msg = do- guard $ isGroupMsg group msg- return $ action--match :: [Event -> Maybe (ZRE ())] -> ZRE ()-match acts = do- msg <- readZ- go acts msg- where- go (act:rest) m = do- case act m of- Nothing -> go rest m- Just a -> unReadZ m >> a-- go [] _ = return ()
src/Data/ZGossip.hs view
@@ -22,9 +22,6 @@ import GHC.Word -import Data.Binary.Strict.Get-import Data.Binary.Put- import Data.ZMQParse import Network.ZRE.Utils (bshow)@@ -65,7 +62,7 @@ encodeZGS :: ZGSMsg -> B.ByteString encodeZGS ZGSMsg{..} = msg where- msg = BL.toStrict $ runPut $ do+ msg = runPut $ do putWord16be zgsSig putWord8 $ cmdCode zgsCmd putInt8 $ fromIntegral zgsVer@@ -103,13 +100,13 @@ return $ ZGSMsg (Just from) zcmd -parseZGS :: [B.ByteString] -> (Either String ZGSMsg, B.ByteString)+parseZGS :: [B.ByteString] -> Either String ZGSMsg parseZGS [from, msg] = parseZgs from msg-parseZGS x = (Left "empty message", bshow x)+parseZGS x = Left "empty message" -parseZgs :: B.ByteString -> B.ByteString -> (Either String ZGSMsg, B.ByteString)+parseZgs :: B.ByteString -> B.ByteString -> Either String ZGSMsg parseZgs from msg = flip runGet msg $ do- sig <- getWord16be+ sig <- getInt16 if sig /= zgsSig then fail "Signature mismatch" else do
src/Data/ZMQParse.hs view
@@ -1,15 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-module Data.ZMQParse where+module Data.ZMQParse (+ getInt8+ , getInt16+ , getInt32+ , parseString+ , parseStrings+ , parseLongString+ , parseKV+ , parseMap+ , putByteStringLen+ , putByteStrings+ , putLongByteStringLen+ , putKV+ , putMap+ , Get.Get()+ , runGet+ , Get.getByteString+ , Put.Put+ , Put.PutM+ , runPut+ , Put.putInt8+ , Put.putWord8+ , Put.putByteString+ , Put.putWord16be+ , Put.putWord32be+ , Put.putInt16be+ , Put.putInt32be+ )+ where import Prelude hiding (putStrLn, take) import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL -import Data.Binary.Strict.Get-import Data.Binary.Put+import Data.Binary.Get hiding (getInt8, runGet)+import Data.Binary.Put hiding (runPut) import qualified Data.Map as M +import qualified Data.Binary.Get as Get+import qualified Data.Binary.Put as Put+ getInt8 :: (Integral a) => Get a getInt8 = fromIntegral <$> getWord8 getInt16 :: (Integral a) => Get a@@ -72,3 +104,11 @@ putInt32be $ fromIntegral $ length ml mapM_ putKV ml where ml = M.toList m++runGet :: Get a -> B.ByteString -> Either String a+runGet g b = case Get.runGetOrFail g (BL.fromStrict b) of+ (Left (_unconsumed, _offset, err)) -> Left err+ (Right (_unconsumed, _offset, res)) -> Right res++runPut :: Put -> B.ByteString+runPut = BL.toStrict . Put.runPut
src/Data/ZRE.hs view
@@ -22,9 +22,6 @@ import GHC.Word -import Data.Binary.Strict.Get-import Data.Binary.Put- import qualified Data.Map as M import qualified Data.Set as S import Data.UUID@@ -64,7 +61,7 @@ deriving (Show, Eq, Ord) zreBeacon :: B.ByteString -> Port -> B.ByteString-zreBeacon uuid port = BL.toStrict $ runPut $ do+zreBeacon uuid port = runPut $ do putByteString "ZRE" -- XXX: for compatibility with zyre implementation -- this should use 0x01 instead, but why when@@ -84,12 +81,12 @@ Nothing -> fail "Unable to parse UUID" parseBeacon :: B.ByteString- -> (Either String (B.ByteString, Integer, UUID, Integer), B.ByteString)+ -> (Either String (B.ByteString, Integer, UUID, Integer)) parseBeacon = runGet $ do lead <- getByteString 3- ver <- fromIntegral <$> getWord8+ ver <- getInt8 uuid <- parseUUID- port <- fromIntegral <$> getWord16be+ port <- getInt16 return (lead, ver, uuid, port) cmdCode :: ZRECmd -> Word8@@ -112,7 +109,7 @@ encodeZRE :: ZREMsg -> [B.ByteString] encodeZRE ZREMsg{..} = msg:(getContent msgCmd) where- msg = BL.toStrict $ runPut $ do+ msg = runPut $ do putWord16be zreSig putWord8 $ cmdCode msgCmd putInt8 $ fromIntegral zreVer@@ -165,8 +162,8 @@ sqn <- getInt16 case runGet parseUUID from of- (Left _err, _) -> fail "No UUID"- (Right uuid, _)-> do+ (Left err) -> fail $ "No UUID: " ++ err+ (Right uuid)-> do if ver /= zreVer then fail "Protocol version mismatch" else do@@ -183,13 +180,13 @@ return $ ZREMsg (Just uuid) sqn Nothing zcmd -parseZRE :: [B.ByteString] -> (Either String ZREMsg, B.ByteString)+parseZRE :: [B.ByteString] -> Either String ZREMsg parseZRE (from:msg:rest) = parseZre from msg rest-parseZRE _ = (Left "empty message", "")+parseZRE _ = Left "empty message" -parseZre :: B.ByteString -> B.ByteString -> Content -> (Either String ZREMsg, B.ByteString)+parseZre :: B.ByteString -> B.ByteString -> Content -> Either String ZREMsg parseZre from msg frames = flip runGet msg $ do- sig <- getWord16be+ sig <- getInt16 if sig /= zreSig then fail "Signature mismatch" else do
src/Network/ZGossip/ZMQ.hs view
@@ -41,10 +41,10 @@ let recv = forever $ do input <- ZMQ.receiveMulti d case parseZGS input of- (Left err, _) -> do+ Left err -> do liftIO $ print $ "Malformed gossip message received: " ++ err liftIO $ print input- (Right msg@ZGSMsg{..}, _) -> do+ Right msg@ZGSMsg{..} -> do liftIO $ handler msg sa <- ZMQ.async spam@@ -64,8 +64,8 @@ forever $ do input <- ZMQ.receiveMulti sock case parseZGS input of- (Left err, _) -> liftIO $ print $ "Malformed gossip message received: " ++ err- (Right ZGSMsg{..}, _) -> do+ Left err -> liftIO $ print $ "Malformed gossip message received: " ++ err+ Right ZGSMsg{..} -> do --liftIO $ print msg res <- liftIO $ handler (fromJust zgsFrom) zgsCmd flip mapM_ res $ \(to, cmd) -> do
src/Network/ZRE.hs view
@@ -20,10 +20,13 @@ , zdebug , znodebug , zquit+ , zrecv , pEndpoint , toASCIIBytes , getApiQueue- , getEventQueue) where+ , getEventQueue+ , module Network.ZRE.Lib+ ) where import Prelude hiding (putStrLn, take) import Control.Monad hiding (join)@@ -42,6 +45,7 @@ import qualified Data.ZRE as Z import Network.ZRE.Beacon import Network.ZRE.Config+import Network.ZRE.Lib import Network.ZRE.Options import Network.ZRE.Peer import Network.ZRE.Types@@ -106,15 +110,15 @@ zrePort <- randPort ipv4 let zreEndpoint = newTCPEndpoint ipv4 zrePort- print zreEndpoint- B.putStrLn $ "Starting with " <> (bshow zreEndpoint)+ when zreDbg $ B.putStrLn $ "Starting with " <> (bshow zreEndpoint) zreName <- getName zreNamed - inQ <- atomically $ newTBQueue 10000- outQ <- atomically $ newTBQueue 10000+ -- 1M events both ways, not sure about this+ inQ <- atomically $ newTBQueue 1000000+ outQ <- atomically $ newTBQueue 1000000 - s <- newZREState zreName zreEndpoint u inQ outQ+ s <- newZREState zreName zreEndpoint u inQ outQ zreDbg -- FIXME: support multiple gossip clients case zreZGossip of@@ -124,11 +128,13 @@ (mCastAddr:_) <- toAddrInfo zreMCast _beaconAsync <- async $ beacon mCastAddr uuid zrePort _beaconRecvAsync <- async $ beaconRecv s zreMCast- apiAsync <- async $ api s- _userAppAsync <- async $ runZ app inQ outQ mapM_ (runIface s zrePort) ifaces + apiAsync <- async $ api s+ threadDelay 500000+ _userAppAsync <- async $ runZ (app >> zquit) inQ outQ+ wait apiAsync return () @@ -169,8 +175,16 @@ DoDebug bool -> atomically $ modifyTVar s $ \x -> x { zreDebug = bool } DoQuit -> do- -- FIXME: wait for empty peer queues- threadDelay (sec (1.0 :: Float))+ let chk = atomically $ do+ s' <- readTVar s+ pqs <- forM (M.toList $ zrePeers s') $ \(_, tp) -> readTVar tp >>= isEmptyTBQueue . peerQueue+ return $ and pqs++ let loop = do+ res <- chk+ unless res $ threadDelay (sec (0.1 :: Float)) >> loop++ loop where incGroupSeq = modifyTVar s $ \x -> x { zreGroupSeq = (zreGroupSeq x) + 1 } @@ -237,7 +251,8 @@ Z.Ping -> atomically $ do msgPeer peer Z.PingOk- emitdbg s $ "ping"+ p <- readTVar peer+ emitdbg s $ B.unwords ["sending pings to ", bshow p] Z.PingOk -> return () Z.Hello endpoint groups groupSeq name headers -> do -- if this peer was already registered
src/Network/ZRE/Beacon.hs view
@@ -27,8 +27,8 @@ forever $ do (msg, addr) <- recvFrom sock 22 case parseBeacon msg of- (Left err, _remainder) -> print err- (Right (_lead, _ver, uuid, port), _) -> do+ Left err -> print err+ Right (_lead, _ver, uuid, port) -> do case addr of x@(SockAddrInet _hisport _host) -> do beaconHandle s (showSockAddrBS x) uuid (fromIntegral port)
src/Network/ZRE/Config.hs view
@@ -3,6 +3,8 @@ module Network.ZRE.Config where import System.Environment+import System.Directory+import System.FilePath.Posix import System.Exit (exitFailure) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T@@ -16,13 +18,14 @@ iniParser :: IniParser ZRECfg iniParser = section "zre" $ do- zreNamed <- B.pack . T.unpack <$> fieldDef "name" (T.pack . B.unpack $ zreNamed def)- zreInterfaces <- fieldDefOf "interfaces" (return . map B.pack . words . T.unpack) []- zreQuietPeriod <- fieldDefOf "quiet-period"(fmap isec . number) (zreQuietPeriod def)- zreDeadPeriod <- fieldDefOf "dead-period"(fmap isec . number) (zreDeadPeriod def)- zreBeaconPeriod <- fieldDefOf "beacon-period"(fmap isec . number) (zreBeaconPeriod def)- zreZGossip <- fieldDefOf "gossip" (fmap Just . parseAttoTCPEndpoint . B.pack . T.unpack) (zreZGossip def)- zreMCast <- fieldDefOf "multicast-group" (parseAttoTCPEndpoint . B.pack . T.unpack) (zreMCast def)+ zreNamed <- B.pack . T.unpack <$> fieldDef "name" (T.pack . B.unpack $ zreNamed def)+ zreInterfaces <- fieldDefOf "interfaces" (return . map B.pack . words . T.unpack) []+ zreQuietPeriod <- fieldDefOf "quiet-period" (fmap isec . number) (zreQuietPeriod def)+ zreDeadPeriod <- fieldDefOf "dead-period" (fmap isec . number) (zreDeadPeriod def)+ zreBeaconPeriod <- fieldDefOf "beacon-period" (fmap isec . number) (zreBeaconPeriod def)+ zreZGossip <- fieldDefOf "gossip" (fmap Just . parseAttoTCPEndpoint . B.pack . T.unpack) (zreZGossip def)+ zreMCast <- fieldDefOf "multicast-group" (parseAttoTCPEndpoint . B.pack . T.unpack) (zreMCast def)+ zreDbg <- fieldDefOf "debug" flag (zreDbg def) return $ ZRECfg {..} parseZRECfg :: FilePath -> IO (Either String ZRECfg)@@ -40,9 +43,21 @@ menv <- lookupEnv "ZRECFG" mname <- lookupEnv "ZRENAME" case menv of- Nothing -> return $ maybe (def) (\x -> def { zreNamed = B.pack x }) mname+ Nothing -> do+ hom <- getHomeDirectory+ let homPth = hom </> ".zre.conf"+ tst <- doesFileExist homPth+ case tst of+ False -> return $ maybeUpdateName def mname+ True -> do+ res <- parseZRECfg homPth+ case res of+ Left err -> putStrLn ("Unable to parse config: " ++ err) >> exitFailure+ Right cfg -> return $ maybeUpdateName cfg mname Just env -> do res <- parseZRECfg env case res of Left err -> putStrLn ("Unable to parse config: " ++ err) >> exitFailure- Right cfg -> return cfg+ Right cfg -> return $ maybeUpdateName cfg mname+ where+ maybeUpdateName cfg mname = maybe cfg (\x -> cfg { zreNamed = B.pack x}) mname
+ src/Network/ZRE/Lib.hs view
@@ -0,0 +1,70 @@+module Network.ZRE.Lib where++import Control.Applicative+import Control.Monad++import Data.Either+import qualified Data.ByteString.Char8 as B++import Data.ZRE (Group)+import Network.ZRE.Types++zrecvWithShout:: (B.ByteString -> ZRE ()) -> ZRE ()+zrecvWithShout f = do+ e <- zrecv+ case e of+ Shout _ _ content _time -> f (B.concat content)+ _ -> return ()++zrecvShouts :: (B.ByteString -> ZRE ()) -> ZRE b+zrecvShouts fn = forever $ zrecvWithShout fn++whenDecodes :: Monad m+ => (msg -> Either a decoded)+ -> (decoded -> m ())+ -> msg+ -> m ()+whenDecodes decoder action content = case decoder content of+ Left _ -> return ()+ Right x -> action x++decodeShouts :: (Monad m, Alternative m)+ => (Event -> Either a decoded)+ -> (decoded -> ZRE ())+ -> Event+ -> m (ZRE ())+decodeShouts fn action msg = do+ guard $ isShout msg+ let res = fn msg+ guard $ isRight res+ case res of+ Left _ -> return $ pure ()+ Right x -> return $ readZ >> action x++isShout :: Event -> Bool+isShout (Shout _uuid _group _content _time) = True+isShout _ = False++isGroupMsg :: Group -> Event -> Bool+isGroupMsg group (Shout _uuid g _content _time) = g == group+isGroupMsg _ _ = False++(==>) :: (Monad m, Alternative m) => (t -> Bool) -> b -> t -> m b+(==>) f act = iff f act++iff :: (Monad m, Alternative m) => (t -> Bool) -> b -> t -> m b+iff f act msg = do+ guard $ f msg+ return $ act++match :: [Event -> Maybe (ZRE ())] -> ZRE ()+match acts = do+ msg <- readZ+ go acts msg+ where+ go (act:rest) m = do+ case act m of+ Nothing -> go rest m+ Just a -> unReadZ m >> a++ go [] _ = return ()
src/Network/ZRE/Options.hs view
@@ -52,6 +52,7 @@ <> short 'g' <> metavar "IP:PORT" <> help "IP:PORT of the gossip server"))+ <*> (flag' False (long "debug" <> short 'd')) attoReadM :: (B.ByteString -> Either String a) -> ReadM a attoReadM p = eitherReader (p . B.pack)
src/Network/ZRE/Peer.hs view
@@ -115,7 +115,7 @@ newPeerFromHello (Hello endpoint groups groupSeq name headers) t uuid s = do emitdbg s "New peer from hello" newPeer s endpoint uuid groups groupSeq (Just name) headers t-newPeerFromHello _ _ _ _ = fail "not a hello message"+newPeerFromHello _ _ _ _ = error "not a hello message" newPeerFromEndpoint :: MonadIO m => Endpoint@@ -176,14 +176,17 @@ pinger :: TVar ZREState -> TVar Peer -> IO b pinger s peer = forever $ do- Peer{..} <- atomically $ readTVar peer+ p@Peer{..} <- atomically $ readTVar peer now <- getCurrentTime if diffUTCTime now peerLastHeard > deadPeriod- then destroyPeer s peerUUID+ then do+ atomically $ emitdbg s $ B.unwords ["Peer over deadPeriod, destroying", bshow p]+ destroyPeer s peerUUID else do let tdiff = diffUTCTime now peerLastHeard if tdiff > quietPeriod then do+ atomically $ emitdbg s $ B.unwords ["Peer over quietPeriod, sending hugz", bshow p] atomically $ writeTBQueue peerQueue $ Ping threadDelay quietPingRate else do
src/Network/ZRE/Types.hs view
@@ -61,6 +61,7 @@ , zreInterfaces :: [B.ByteString] , zreMCast :: Endpoint , zreZGossip :: Maybe Endpoint+ , zreDbg :: Bool } deriving (Show) defMCastEndpoint :: Endpoint@@ -75,6 +76,7 @@ , zreInterfaces = [] , zreZGossip = Nothing , zreMCast = defMCastEndpoint+ , zreDbg = False } instance Default ZRECfg where@@ -148,10 +150,13 @@ newtype ZRE a = Z { runZ' :: ReaderT (EventQueue, APIQueue) IO a-}- deriving (Functor, Applicative, Monad, MonadIO,- MonadBase IO,- MonadReader (EventQueue, APIQueue))+ } deriving (+ Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadBase IO+ , MonadReader (EventQueue, APIQueue)) instance MonadBaseControl IO ZRE where type StM ZRE a = a@@ -206,6 +211,9 @@ zquit :: ZRE () zquit = writeZ $ DoQuit +zrecv :: ZRE (Event)+zrecv = readZ+ maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM err f value = value >>= maybe err f @@ -214,8 +222,9 @@ -> UUID -> EventQueue -> APIQueue+ -> Bool -> IO (TVar ZREState)-newZREState name endpoint u inQ outQ = atomically $ newTVar $+newZREState name endpoint u inQ outQ dbg = atomically $ newTVar $ ZREState { zreUUID = u , zrePeers = M.empty@@ -225,7 +234,7 @@ , zreGroupSeq = 0 , zreName = name , zreHeaders = M.empty- , zreDebug = False+ , zreDebug = dbg , zreIn = inQ , zreOut = outQ , zreIfaces = M.empty
src/Network/ZRE/ZMQ.hs view
@@ -44,8 +44,8 @@ input <- ZMQ.receiveMulti sock now <- liftIO $ getCurrentTime case parseZRE input of- (Left err, _) -> liftIO $ print $ "Malformed message received: " ++ err- (Right msg, _) -> do+ Left err -> liftIO $ print $ "Malformed message received: " ++ err+ Right msg -> do let updateTime = \x -> x { msgTime = Just now } void $ liftIO $ handler (updateTime msg) return ()
src/System/ZMQ4/Endpoint.hs view
@@ -80,12 +80,13 @@ t <- A.takeWhile (/=':') _ <- string "://" r <- case t of- "tcp" -> pure TCP- "ipc" -> pure IPC+ "tcp" -> pure TCP+ "udp" -> pure UDP+ "ipc" -> pure IPC "inproc" -> pure InProc- "pgm" -> pure PGM- "epgm" -> pure EPGM- _ -> fail $ "Unknown transport" ++ (B.unpack t)+ "pgm" -> pure PGM+ "epgm" -> pure EPGM+ _ -> fail $ "Unknown transport " ++ (B.unpack t) return r
+ test/Arbitrary.hs view
@@ -0,0 +1,74 @@+module Arbitrary where++import Test.QuickCheck+import Test.QuickCheck.Instances++import Data.ByteString+import qualified Data.ByteString.Char8 as B++import Data.ZRE+import qualified Data.ZGossip as ZG+import System.ZMQ4.Endpoint++instance Arbitrary ZG.ZGSCmd where+ arbitrary = oneof [+ return ZG.Hello+ , ZG.Publish <$> arbitrary <*> arbitrary <*> (abs <$> arbitrary)+ , return ZG.Ping+ , return ZG.PingOk+ , return ZG.Invalid+ ]++instance Arbitrary ZG.ZGSMsg where+ arbitrary = ZG.ZGSMsg <$> (Just <$> arbitrary) <*> arbitrary++instance Arbitrary Transport where+ arbitrary = oneof [+ pure TCP+ , pure UDP+ , pure IPC+ , pure InProc+ , pure PGM+ , pure EPGM+ ]++instance Arbitrary Endpoint where+ arbitrary = Endpoint <$> arbitrary+ <*> (arbitrary `suchThat` (not . B.elem ':'))+ <*> (fmap abs <$> arbitrary)+++instance Arbitrary ZRECmd where+ arbitrary = oneof [+ Hello <$> arbitrary+ <*> arbitrary+ <*> (abs <$> arbitrary)+ <*> arbitrary+ <*> arbitrary++ , Whisper <$> arbitrary+ , Shout <$> arbitrary <*> arbitrary++ , Join <$> arbitrary+ <*> (abs <$> arbitrary)+ , Leave <$> arbitrary+ <*> (abs <$> arbitrary)++ , pure Ping+ , pure PingOk+ ]++instance Arbitrary ZREMsg where+ arbitrary = ZREMsg <$> (Just <$> arbitrary)+ <*> (abs <$> arbitrary)+ <*> pure Nothing+ <*> arbitrary++roundTrip :: Eq a+ => (a -> b)+ -> (b -> Either String a)+ -> a+ -> Bool+roundTrip putter getter x =+ Right x == (getter . putter $ x)+
+ test/Binary.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}++module Binary where++import Test.QuickCheck+import Test.QuickCheck.All+import Test.QuickCheck.Instances+import System.Exit++import Data.ZMQParse++roundTrip :: Eq a => (a -> Put) -> Get a -> a -> Bool+roundTrip putter getter x =+ Right x == runGet getter (runPut (putter x))++prop_i8 = roundTrip putInt8 getInt8+prop_i16 = roundTrip putInt16be getInt16+prop_i32 = roundTrip putInt32be getInt32++prop_str = roundTrip putByteStringLen parseString++prop_long_str = roundTrip putLongByteStringLen parseLongString++prop_strings = roundTrip putByteStrings parseStrings++prop_kv = roundTrip putKV parseKV++prop_map = roundTrip putMap parseMap++return []+runTests :: IO Bool+runTests = $quickCheckAll
+ test/Endpoint.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}++module Endpoint where++import Test.QuickCheck.All+import System.ZMQ4.Endpoint++import Arbitrary++prop_endpoint = roundTrip pEndpoint parseAttoEndpoint++return []+runTests :: IO Bool+runTests = $quickCheckAll
test/Spec.hs view
@@ -1,2 +1,20 @@+module Main where++import System.Exit++import qualified Endpoint+import qualified ZGossip+import qualified ZRE+import qualified Binary+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = do+ good <- and <$> sequence [+ Binary.runTests+ , Endpoint.runTests+ , ZGossip.runTests+ , ZRE.runTests+ ]+ if good+ then exitSuccess+ else exitFailure
+ test/ZGossip.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module ZGossip where++import Test.QuickCheck.All+import Data.Maybe++import Data.ZGossip++import Arbitrary++prop_zgs = roundTrip+ (\z -> (\x -> [fromJust $ zgsFrom z, x]) . encodeZGS $ z)+ parseZGS++return []+runTests :: IO Bool+runTests = $quickCheckAll
+ test/ZRE.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module ZRE where++import Test.QuickCheck.All+import Data.Maybe++import Data.UUID (toByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL++import Arbitrary+import Data.ZRE++prop_zre = roundTrip+ (\z -> (\x -> ('1' `B.cons` (BL.toStrict $ toByteString $ fromJust $ msgFrom z)):x) . encodeZRE $ z)+ parseZRE++return []+runTests :: IO Bool+runTests = $quickCheckAll
zre.cabal view
@@ -1,14 +1,18 @@ name: zre-version: 0.1.0.1+version: 0.1.0.2 synopsis: ZRE protocol implementation-description: See README.rst-homepage: https://github.com/vpsfreecz/haskell-zre/+description: Peer-to-peer local area networking with reliable group messaging+ and automatic peer discovery.++ ZRE protocol implementation according to https://rfc.zeromq.org/spec:36/ZRE/++homepage: https://github.com/sorki/haskell-zre/ license: BSD3 license-file: LICENSE author: Richard Marko maintainer: srk@48.io-copyright: 2016 Richard Marko-category: Web+copyright: 2020 Richard Marko+category: Networking build-type: Simple -- extra-source-files: cabal-version: >=1.10@@ -18,6 +22,7 @@ exposed-modules: Network.ZRE , Network.ZRE.Beacon , Network.ZRE.Config+ , Network.ZRE.Lib , Network.ZRE.Options , Network.ZRE.Parse , Network.ZRE.Peer@@ -36,12 +41,14 @@ , attoparsec , data-default , network+ , network-bsd , network-info , network-multicast , binary- , binary-strict , bytestring , containers+ , directory+ , filepath , mtl , monad-control , optparse-applicative@@ -148,11 +155,20 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs+ other-modules: Arbitrary+ , Binary+ , Endpoint+ , ZGossip+ , ZRE build-depends: base+ , bytestring , zre+ , QuickCheck+ , quickcheck-instances+ , uuid ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 source-repository head type: git- location: https://git.48.io/zre/+ location: https://github.com/sorki/haskell-zre