zyre2 (empty) → 0.1.1.0

raw patch · 16 files changed

+1566/−0 lines, 16 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, inline-c, text, zyre2

Files

.gitignore +4/−0
ChangeLog.md +23/−0
LICENSE +21/−0
README.md +21/−0
Setup.hs +2/−0
app/Main.hs +90/−0
package.yaml +61/−0
src/Network/Zyre2.hs +125/−0
src/Network/Zyre2/Bindings.hs +242/−0
src/Network/Zyre2/Configuration.hs +80/−0
src/Network/Zyre2/Types.hs +55/−0
src/Network/Zyre2/ZMsg.hs +187/−0
src/Network/Zyre2/Zyre.hs +502/−0
stack.yaml +67/−0
test/Spec.hs +2/−0
zyre2.cabal +84/−0

+ .gitignore view

@@ -0,0 +1,4 @@+.stack-work/+*~+stack.yaml.lock+zyre-2.0.1.tar.gz

+ ChangeLog.md view

@@ -0,0 +1,23 @@+# Changelog for zyre2+++## 0.1.1.0++This minor release adds the function 'peerName' to allow retrieving a nodes name by its id without manually having to track Enter/Exit messages.+It also removes some misleading haddock documentation.++## 0.1.0.3++Initial release. Versions 0.1.0.0 through 0.1.0.2 are internal development releases.+Developed and tested with zyre release 2.0.1.++Supports most functionality of zyre, excluding:++ * Draft API+ * Gossip protocol discovery++The following zyre functions are excluded:++ * int zyre_set_endpoint (zyre_t *self, const char *format, ...) CHECK_PRINTF (2);+ * void zyre_gossip_bind (zyre_t *self, const char *format, ...) CHECK_PRINTF (2);+ * void zyre_gossip_connect (zyre_t *self, const char *format, ...) CHECK_PRINTF (2);

+ LICENSE view

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Emil Nylind++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ README.md view

@@ -0,0 +1,21 @@+# Zyre bindings for Haskell++This is a haskell package 'zyre2' for using the C library zyre. The package requires+'czmq' and 'zyre' to be installed on the system.++The bindings has support for all zyre features, except the following:++ * Gossip protocol discovery+ * Binding specfic endpoints++## Experimental++The package is currently in an experimental state. The bindings have been tested and validated using the standard zyre examples (minimal.c, chat.c) with 'valgrind', and no memory leaks are found. That stated, there could be issues which have not been uncovered during testing and the library could potentially leak memory or at worst segfault your entire process.++The API may also drastically change, should the current API prove cumbersome to work with.++Tread with care (for now).++## Documentation++The package is thoroughly documented with haddock, which can be found at X or generated using 'cabal haddock' or 'stack haddock'.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (forM_, join, void)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text as T (Text, pack, unpack)+import qualified Network.Zyre2 as Zyre+import System.Environment (getArgs)++-- | Main function that handles example selection.+main :: IO ()+main = do+  args <- getArgs+  case args of+    ("minimal" : x : _) -> minimal (T.pack x)+    ("chat" : x : _) -> chat (T.pack x)+    _ -> error "Unknown example."++-- | Zyre chat example adapted from examples/minimal/minimal.c+minimal :: Text -> IO ()+minimal name = do+  let room = "ROOM"++  ctx <- Zyre.new (Just name)+  ctx <- Zyre.start ctx+  Zyre.join ctx room++  forM_ [0 .. 10] $ \_ -> do+    Zyre.shouts ctx room ("Hello from " <> name)++    threadDelay $ 1000 * 250+    mMsg <- Zyre.recv ctx+    print mMsg+    case mMsg of+      Just Zyre.Shout {} -> print (fst . Zyre.popText =<< mMsg)+      _ -> pure ()++  Zyre.leave ctx room++  ctx <- Zyre.stop ctx+  void . Zyre.destroy $ ctx++-- | Zyre chat example adapted from examples/chat/chat.c+chat :: Text -> IO ()+chat name = do+  let room = "CHAT"++  terminateRef <- newIORef False++  ctx <- Zyre.new (Just name)+  ctx <- Zyre.start ctx+  Zyre.join ctx room++  -- Fork a thread to receive messages and output them to stdout.+  void . forkIO $+    whileM_ (readIORef terminateRef) $ do+      mMsg <- Zyre.recv ctx+      case mMsg of+        Just zmsg@Zyre.Shout {} -> do+          putStr $ T.unpack $ Zyre._zmsgName zmsg <> ": "+          case Zyre.popText zmsg of+            (Just m, _) -> putStrLn $ T.unpack m+            _ -> putStrLn "Message could not be decoded or was empty"+        Just zmsg@Zyre.Join {} -> putStrLn $ T.unpack $ Zyre._zmsgName zmsg <> " has joined the chat"+        Just zmsg@Zyre.Leave {} -> putStrLn $ T.unpack $ Zyre._zmsgName zmsg <> " has left the chat"+        Just zmsg@Zyre.Evasive {} -> putStrLn $ T.unpack $ Zyre._zmsgName zmsg <> " is being evasive"+        Just zmsg@Zyre.Silent {} -> putStrLn $ T.unpack $ Zyre._zmsgName zmsg <> " is being silent"+        _ -> pure ()++  whileM_ (readIORef terminateRef) $ do+    line <- fmap T.pack getLine+    case line of+      "$TERM" -> do+        writeIORef terminateRef True+        Zyre.leave ctx room+        ctx <- Zyre.stop ctx+        void $ Zyre.destroy ctx+      _ -> void $ Zyre.shouts ctx room line++-- | Loop over an action until monadic condition is fulfilled to stop.+whileM_ :: (Monad m) => m Bool -> m () -> m ()+whileM_ condition fn = do+  stop <- condition+  if not stop+    then do+      fn+      whileM_ condition fn+    else pure ()

+ package.yaml view

@@ -0,0 +1,61 @@+name:                zyre2+version:             0.1.1.0+github:              "skrioify/haskell-zyre2"+license:             MIT+author:              "Emil Nylind"+maintainer:          "emil@nylind.se"+copyright:           "2022 Emil Nylind"++extra-source-files:+- README.md+- ChangeLog.md++# Metadata used when publishing your package+synopsis:            Haskell zyre bindings for reliable group messaging over local area networks.+category:            Web++# To avoid duplicated efforts in documentation and dealing with the+# complications of embedding Haddock markup inside cabal files, it is+# common to point users to the README.md file.+description:         Please see the README on GitHub at <https://github.com/skrioify/haskell-zyre2#readme>++dependencies:+- base >= 4.7 && < 5+- inline-c >= 0.9.1 && < 0.10+- containers >= 0.6.5 && < 0.7+- text >= 1.2.4 && < 1.3+- bytestring >= 0.10.12 && < 0.11++library:+  source-dirs: src+  extra-lib-dirs:+  - /usr/local/lib+  extra-libraries: +  - zyre+  - czmq+  exposed-modules:+  - Network.Zyre2+  - Network.Zyre2.Configuration++executables:+  zyre-example-exe:+    main:                Main.hs+    source-dirs:         app+    ghc-options:+    - -threaded+    - -rtsopts+    - -with-rtsopts=-N+    dependencies:+    - zyre2++tests:+  zyre2-test:+    main:                Spec.hs+    source-dirs:         test+    ghc-options:+    - -threaded+    - -rtsopts+    - -with-rtsopts=-N+    dependencies:+    - zyre2+

+ src/Network/Zyre2.hs view

@@ -0,0 +1,125 @@+-- | Zyre provides reliable group messaging over local area networks. It has these key characteristics:+--+-- * Zyre needs no administration or configuration.+-- * Peers may join and leave the network at any time.+-- * Peers talk to each other without any central brokers or servers.+-- * Peers can talk directly to each other.+-- * Peers can join groups, and then talk to groups.+-- * Zyre is reliable, and loses no messages even when the network is heavily loaded.+-- * Zyre is fast and has low latency, requiring no consensus protocols.+-- * Zyre is designed for WiFi networks, yet also works well on Ethernet networks.+-- * Time for a new peer to join a network is about one second.+--+-- Typical use cases for Zyre are:+--+-- * Local service discovery.+-- * Clustering of a set of services on the same Ethernet network.+-- * Controlling a network of smart devices (Internet of Things).+-- * Multi-user mobile applications (like smart classrooms).+--+-- This package provides a haskell interface to the Zyre 2.0.1 API. The+-- package requires the c libraries czmq and zyre to be installed on the+-- system. See https://github.com/zeromq/zyre for specifics.+module Network.Zyre2+  ( -- * Context Lifecycle+    ZyreContext,+    new,+    start,+    stop,+    destroy,++    -- * Context information+    uuid,+    name,+    version,++    -- * Group membership+    join,+    leave,+    ownGroups,+    peerGroups,++    -- * Peers+    peers,+    peersByGroup,+    peerAddress,+    peerName,+    peerHeaderValue,++    -- * Sending and receiving messages+    shout,+    shouts,+    whisper,+    whispers,+    recv,++    -- * Constructing messages+    ZMsg (..),+    msgShout,+    msgWhisper,++    -- ** Adding data+    pushMem,+    pushText,+    addMem,+    addText,++    -- ** Frames+    ZFrame,+    frameData,++    -- ** Deconstructing messages+    popText,+    popMem,++    -- * Phantom tags for lifecycle state+    ZCreated,+    ZDestroyed,+    ZRunning,+    ZStopped,+  )+where++import Network.Zyre2.Types+  ( ZCreated,+    ZDestroyed,+    ZRunning,+    ZStopped,+    ZyreContext,+  )+import Network.Zyre2.ZMsg+  ( ZFrame,+    ZMsg (..),+    addMem,+    addText,+    frameData,+    msgShout,+    msgWhisper,+    popMem,+    popText,+    pushMem,+    pushText,+  )+import Network.Zyre2.Zyre+  ( destroy,+    join,+    leave,+    name,+    new,+    ownGroups,+    peerGroups,+    peers,+    peerAddress,+    peerName,+    peerHeaderValue,+    peersByGroup,+    recv,+    shout,+    shouts,+    start,+    stop,+    uuid,+    version,+    whisper,+    whispers,+  )

+ src/Network/Zyre2/Bindings.hs view

@@ -0,0 +1,242 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module provides minimal wrapping between C and Haskell.+--+-- Prefer to use 'Network.Zyre2.Zyre2' instead, or you'll need intimate knowledge+-- of the C library requirements to avoid segfaults, manually free memory+-- and similar.+--+-- This module deals entirely with C-typed data from Haskells FFI.+module Network.Zyre2.Bindings where++import Data.ByteString (ByteString)+import Foreign (Ptr)+import Foreign.C.String (CString)+import Foreign.C.Types (CInt)+import qualified Language.C.Inline as C+import Data.Word (Word64)++C.context (C.baseCtx <> C.bsCtx)+C.include "zyre.h"++-- Lifecycle management bindings++zyreNew :: CString -> IO (Ptr ())+zyreNew name = do+  [C.exp| void* { zyre_new($(char* name)) } |]++zyreStart :: Ptr () -> IO CInt+zyreStart ptr =+  [C.exp| int { zyre_start($(void* ptr)) } |]++zyreStop :: Ptr () -> IO ()+zyreStop ptr = do+  [C.exp| void { zyre_stop($(void* ptr)) } |]++zyreDestroy :: Ptr () -> IO ()+zyreDestroy ptr = do+  [C.block| void {+      zyre_t* node = $(void* ptr);+      zyre_destroy(&node);+  } |]++-- Info++zyreUuid :: Ptr () -> IO CString+zyreUuid ptr = do+  [C.exp| const char* { zyre_uuid($(void* ptr)) } |]++zyreName :: Ptr () -> IO CString+zyreName ptr = do+  [C.exp| const char* { zyre_name($(void* ptr)) } |]++zyreVersion :: IO Word64+zyreVersion = do+  [C.exp| uint64_t { zyre_version() } |]++-- Configuration++zyreSetName :: Ptr () -> CString -> IO ()+zyreSetName ptr name = do+  [C.exp| void { zyre_set_name($(void* ptr), $(const char* name)) } |]++zyreSetHeader :: Ptr () -> CString -> CString -> IO ()+zyreSetHeader ptr header_name header_value = do+  [C.exp| void { zyre_set_header($(void* ptr), $(const char* header_name), "%s", $(const char* header_value)) } |]++zyreSetVerbose :: Ptr () -> IO ()+zyreSetVerbose ptr = do+  [C.exp| void { zyre_set_verbose($(void* ptr)) } |]++zyreSetPort :: Ptr () -> CInt -> IO ()+zyreSetPort ptr port = do+  [C.exp| void { zyre_set_port($(void* ptr), $(int port)) } |]++zyreSetEvasiveTimeout :: Ptr () -> CInt -> IO ()+zyreSetEvasiveTimeout ptr timeout = do+  [C.exp| void { zyre_set_evasive_timeout($(void* ptr), $(int timeout)) } |]++zyreSetSilentTimeout :: Ptr () -> CInt -> IO ()+zyreSetSilentTimeout ptr timeout = do+  [C.exp| void { zyre_set_silent_timeout($(void* ptr), $(int timeout)) } |]++zyreSetExpiredTimeout :: Ptr () -> CInt -> IO ()+zyreSetExpiredTimeout ptr timeout = do+  [C.exp| void { zyre_set_expired_timeout($(void* ptr), $(int timeout)) } |]++zyreSetInterval :: Ptr () -> CInt -> IO ()+zyreSetInterval ptr interval = do+  [C.exp| void { zyre_set_interval($(void* ptr), $(int interval)) } |]++zyreSetInterface :: Ptr () -> CString -> IO ()+zyreSetInterface ptr interface = do+  [C.exp| void { zyre_set_interface($(void* ptr), $(const char* interface)) } |]++-- Zyre 'basic' use++zyreJoin :: Ptr () -> CString -> IO CInt+zyreJoin ptr room = do+  [C.exp| int { zyre_join($(void* ptr), $(char* room)) } |]++zyreLeave :: Ptr () -> CString -> IO CInt+zyreLeave ptr room = do+  [C.exp| int { zyre_leave($(void* ptr), $(char* room)) } |]++zyreShout :: Ptr () -> CString -> Ptr () -> IO CInt+zyreShout ctx_ptr room msg_ptr = do+  [C.block| int {+      zmsg_t* msg = $(void* msg_ptr); +      return zyre_shout($(void* ctx_ptr), $(const char* room), &msg);+  } |]++zyreShouts :: Ptr () -> CString -> CString -> IO CInt+zyreShouts ptr room msg = do+  [C.exp| int { zyre_shouts($(void* ptr), $(const char* room), "%s", $(const char* msg)) } |]++zyreWhisper :: Ptr () -> CString -> Ptr () -> IO CInt+zyreWhisper ctx_ptr peer msg_ptr = do+  [C.block| int {+      zmsg_t* msg = $(void* msg_ptr); +      return zyre_whisper($(void* ctx_ptr), $(const char* peer), &msg);+  } |]++zyreWhispers :: Ptr () -> CString -> CString -> IO CInt+zyreWhispers ptr peer msg = do+  [C.exp| int { zyre_whispers($(void* ptr), $(const char* peer), "%s", $(const char* msg)) } |]++zyreRecv :: Ptr () -> IO (Ptr ())+zyreRecv ptr = do+  [C.exp| void* { zyre_recv($(void* ptr)) } |]++zyrePopStrFrame :: Ptr () -> IO CString+zyrePopStrFrame ptr = do+  [C.exp| char* { zmsg_popstr($(void* ptr)) } |]++zyrePopFrame :: Ptr () -> IO (Ptr ())+zyrePopFrame ptr = do+  [C.exp| void* { zmsg_pop($(void* ptr)) } |]++zyreNextFrame :: Ptr () -> IO (Ptr ())+zyreNextFrame ptr = do+  [C.exp| void* { zmsg_next($(void* ptr)) } |]++zyreFrameSize :: Ptr () -> IO CInt+zyreFrameSize ptr = do+  [C.exp| int { zframe_size($(void* ptr)) } |]++zyreFrameData :: Ptr () -> IO (Ptr C.CChar)+zyreFrameData ptr = do+  [C.exp| char* { zframe_data($(void* ptr)) } |]++zyreDestroyFrame :: Ptr () -> IO ()+zyreDestroyFrame ptr = do+  [C.block| void {+    zframe_t* frame = $(void* ptr);+    zframe_destroy(&frame);+  } |]++zyreNewZMsg :: IO (Ptr ())+zyreNewZMsg = do+  [C.exp| void* { zmsg_new() } |]++zyreAddFrame :: Ptr () -> ByteString -> IO CInt+zyreAddFrame ptr bs = do+  [C.exp| int { zmsg_addmem($(void* ptr), $bs-ptr:bs, $bs-len:bs) } |]++{- Functions regarding zmsg_t -}++zyreZmsgPrint :: Ptr () -> IO ()+zyreZmsgPrint ptr = do+  [C.exp| void { zmsg_print($(void* ptr))} |]++zyreZmsgDestroy :: Ptr () -> IO ()+zyreZmsgDestroy ptr = do+  [C.block| void {+      zmsg_t *msg = $(void* ptr); +      zmsg_destroy(&msg);+  } |]++{- Functions regarding headers -}++zyreUnpackHeaders :: Ptr () -> IO (Ptr ())+zyreUnpackHeaders ptr =+  [C.exp| void* { zhash_unpack($(void* ptr)) } |]++zyreNextHeader :: Ptr () -> IO CString+zyreNextHeader ptr =+  [C.exp| const char* { zhash_next($(void* ptr)) } |]++zyreHeaderCursor :: Ptr () -> IO CString+zyreHeaderCursor ptr =+  [C.exp| const char* { zhash_cursor($(void* ptr)) } |]++zyreDestroyHeaders :: Ptr () -> IO ()+zyreDestroyHeaders ptr =+  [C.block| void {+    zhash_t* table = $(void* ptr); +    zhash_destroy(&table);+  } |]++{- Functions regarding peer lookup -}++zyrePeers :: Ptr () -> IO (Ptr ())+zyrePeers ptr =+  [C.exp| void* { zyre_peers($(void* ptr))} |] ++zyrePeersByGroup :: Ptr () -> CString -> IO (Ptr ())+zyrePeersByGroup ptr str =+  [C.exp| void* { zyre_peers_by_group($(void* ptr), $(const char* str))} |]++zyrePeerAddress :: Ptr () -> CString -> IO CString+zyrePeerAddress ptr str =+  [C.exp| const char* { zyre_peer_address($(void* ptr), $(const char* str))} |]++zyrePeerHeaderValue :: Ptr () -> CString -> CString -> IO CString+zyrePeerHeaderValue ptr peer headerValue =+  [C.exp| const char* { zyre_peer_header_value($(void* ptr), $(const char* peer), $(const char* headerValue))} |]++{- Lookups regarding groups -}++zyreOwnGroups :: Ptr () -> IO (Ptr ())+zyreOwnGroups ptr =+  [C.exp| void* { zyre_own_groups($(void* ptr))} |] ++zyrePeerGroups :: Ptr () -> IO (Ptr ())+zyrePeerGroups ptr =+  [C.exp| void* { zyre_peer_groups($(void* ptr))} |] ++++{- Functions regarding zlist_t -}++zyreZListNext :: Ptr () -> IO CString+zyreZListNext ptr =+  [C.exp| const char* { zlist_next($(void* ptr)) } |] ++zyreZListDestroy :: Ptr () -> IO ()+zyreZListDestroy ptr =+  [C.block| void {+    zlist_t* list = $(void* ptr);+    zlist_destroy(&list);+  } |]

+ src/Network/Zyre2/Configuration.hs view

@@ -0,0 +1,80 @@+-- | Provides configuration functions to handle setting up non-default+-- options and toggles.+module Network.Zyre2.Configuration where++import Data.Text (Text)+import qualified Data.Text as T+import Foreign.C.String (newCString)+import Foreign.Marshal.Alloc (free)+import Network.Zyre2.Bindings+  ( zyreSetEvasiveTimeout,+    zyreSetExpiredTimeout,+    zyreSetHeader,+    zyreSetInterface,+    zyreSetInterval,+    zyreSetName,+    zyreSetPort,+    zyreSetSilentTimeout,+    zyreSetVerbose,+  )+import Network.Zyre2.Types (ZCreated, ZyreContext (ZyreContext), unlessStale)++-- | Set the name of the context.+setName :: ZyreContext ZCreated -> Text -> IO ()+setName zctx@(ZyreContext ptr _ _) name = unlessStale zctx $ do+  cname <- newCString (T.unpack name)+  zyreSetName ptr cname+  free cname++-- | Set a header value. Headers are sent with every 'Enter' message.+setHeader :: ZyreContext ZCreated -> Text -> Text -> IO ()+setHeader zctx@(ZyreContext ptr _ _) headerName headerValue = unlessStale zctx $ do+  cheaderName <- newCString (T.unpack headerName)+  cheaderValue <- newCString (T.unpack headerValue)+  zyreSetHeader ptr cheaderName cheaderValue+  free cheaderName+  free cheaderValue++-- | Enable verbose mode, logging most actions zyre does.+setVerbose :: ZyreContext ZCreated -> IO ()+setVerbose zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  zyreSetVerbose ptr++-- | Set a specific port that zyre uses. By default zyre uses an ephemereal port.+setPort :: ZyreContext ZCreated -> Int -> IO ()+setPort zctx@(ZyreContext ptr _ _) port = unlessStale zctx $ do+  zyreSetPort ptr (fromIntegral port)++-- | Set the time in milliseconds for a node to be considered evasive.+-- Default is 5000.+setEvasiveTimeout :: ZyreContext ZCreated -> Int -> IO ()+setEvasiveTimeout zctx@(ZyreContext ptr _ _) timeout = unlessStale zctx $ do+  zyreSetEvasiveTimeout ptr (fromIntegral timeout)++-- | Set the time in milliseconds for a node to be considered silent.+-- Default is 5000.+setSilentTimeout :: ZyreContext ZCreated -> Int -> IO ()+setSilentTimeout zctx@(ZyreContext ptr _ _) timeout = unlessStale zctx $ do+  zyreSetSilentTimeout ptr (fromIntegral timeout)++-- | Set the time in milliseconds for a node to be considered expired.+-- Default is 30000.+setExpiredTimeout :: ZyreContext ZCreated -> Int -> IO ()+setExpiredTimeout zctx@(ZyreContext ptr _ _) timeout = unlessStale zctx $ do+  zyreSetExpiredTimeout ptr (fromIntegral timeout)++-- | Set the UDP beaconing interval. A node will instantly beacon on+-- connecting, regardless of interval.+-- Default is 1000.+setInterval :: ZyreContext ZCreated -> Int -> IO ()+setInterval zctx@(ZyreContext ptr _ _) interval = unlessStale zctx $ do+  zyreSetInterval ptr (fromIntegral interval)++-- | Set network interface for UDP beacons. If you do not set this, CZMQ will+-- choose an interface for you. On boxes with several interfaces you should+-- specify which one you want to use, or strange things can happen.+setInterface :: ZyreContext ZCreated -> Text -> IO ()+setInterface zctx@(ZyreContext ptr _ _) interface = unlessStale zctx $ do+  cinterface <- newCString (T.unpack interface)+  zyreSetInterface ptr cinterface+  free cinterface

+ src/Network/Zyre2/Types.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Holds some types that the modules requires in common.+module Network.Zyre2.Types where++import Control.Exception (Exception, throw)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Map.Strict as Map+import Data.Text+import Data.Typeable (Typeable)+import Data.Word (Word32)+import Foreign (Ptr)++-- | Runtime exceptions that can be thrown.+data ZyreException+  = StaleZyreContextException+  | ZyreMsgDontSupportFramesException+  deriving (Show, Typeable)++instance Exception ZyreException++-- Context to apply to zyre functions.++-- | A context handle for zyre contexts. Holds relevant state for+-- the context, and is tagged with the state of the context.+-- E.g. 'ZCreated', 'ZRunning', 'ZStopped', 'ZDestroyed'.+data ZyreContext state = ZyreContext+  { _zyreContextPtr :: Ptr (),+    _zyreContextStale :: IORef Bool,+    -- | Mapping of node-ids to node names.+    _zyreContextNodeNames :: IORef (Map.Map Text Text)+  }++-- Phantom tags for the zyre context.++-- | Phantom tag for a created context.+data ZCreated = ZCreated++-- | Phantom tag for a running context.+data ZRunning = ZRunning++-- | Phantom tag for a stopped context.+data ZStopped = ZStopped++-- | Phantom tag for a destroyed context.+data ZDestroyed = ZDestroyed++-- | Perform an IO a action unless the context is stale, then throw+-- a 'StaleZyreContextException' instead.+unlessStale :: ZyreContext s -> IO a -> IO a+unlessStale (ZyreContext _ stale _) fn = do+  isStale <- readIORef stale+  if isStale+    then throw StaleZyreContextException+    else fn

+ src/Network/Zyre2/ZMsg.hs view

@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Message types for sending and receiving from a Zyre peer network.+module Network.Zyre2.ZMsg+  ( ZMsg (..),+    ZFrame,+    pop,+    pushText,+    addText,+    popText,+    pushMem,+    addMem,+    popMem,+    mkFrame,+    frameData,+    msgWhisper,+    msgShout,+  )+where++import Control.Exception (throw)+import qualified Data.Bifunctor+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.List as List+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as T+import Network.Zyre2.Types (ZyreException (ZyreMsgDontSupportFramesException))++-- | Message-types supported and published by zyre.+data ZMsg+  = -- | A peer has joined the peer network.+    Enter+      { -- | The UUID of the sending node.+        _zmsgFromNode :: Text,+        -- | The name of the sending node.+        _zmsgName :: Text,+        -- | Dictionary containing the headers.+        _zmsgHeaders :: [(Text, Text)],+        -- | The ip and port of the sending node. E.g. tcp://127.0.0.1:8344+        _zmsgIpPort :: Text+      }+  | -- | A peer has not sent a message within the 'evasive' interval period.+    -- The peer will be pinged.+    Evasive+      { _zmsgFromNode :: Text,+        _zmsgName :: Text+      }+  | -- | A peer has been silent and not responded to PING messages for the 'silent' interval period.+    Silent+      { _zmsgFromNode :: Text,+        _zmsgName :: Text+      }+  | -- | A peer has exited the peer network.+    Exit+      { _zmsgFromNode :: Text,+        _zmsgName :: Text+      }+  | -- | A peer has joined a group.+    Join+      { _zmsgFromNode :: Text,+        _zmsgName :: Text,+        _zmsgGroupName :: Text+      }+  | -- | A peer has left a group.+    Leave+      { _zmsgFromNode :: Text,+        _zmsgName :: Text,+        -- | The name of the group which the message concerns.+        _zmsgGroupName :: Text+      }+  | -- | A peer has whispered to this node.+    Whisper+      { _zmsgFromNode :: Text,+        _zmsgName :: Text,+        -- | The message content, coded as 'ZFrame's. A message may hold 0 or more frames.+        -- Note: a ZMsg with 0 frames supplied to 'Network.Zyre2.shout' or 'Network.Zyre2.whisper' will be ignored and not sent.+        _zmsgMessage :: [ZFrame]+      }+  | -- | A peer has shouted in a group.+    Shout+      { _zmsgFromNode :: Text,+        _zmsgName :: Text,+        _zmsgGroupName :: Text,+        _zmsgMessage :: [ZFrame]+      }+  | -- | The zyre context which is being listened to has been stopped.+    Stop+  deriving (Show)++-- | A frame of binary data. See 'Network.Zyre2.ZMsg.mkFrame' and 'Network.Zyre2.ZMsg.frameData'.+newtype ZFrame = ZFrame ByteString++instance Show ZFrame where+  show (ZFrame _) = "ZFrame[Bytes]"++{- Utility functions -}++pushFrame :: ZMsg -> ZFrame -> ZMsg+pushFrame zmsg@Whisper {} zframe = zmsg {_zmsgMessage = zframe : _zmsgMessage zmsg}+pushFrame zmsg@Shout {} zframe = zmsg {_zmsgMessage = zframe : _zmsgMessage zmsg}+pushFrame _ _ = throw ZyreMsgDontSupportFramesException++addFrame :: ZMsg -> ZFrame -> ZMsg+addFrame zmsg@Whisper {} zframe = zmsg {_zmsgMessage = _zmsgMessage zmsg <> [zframe]}+addFrame zmsg@Shout {} zframe = zmsg {_zmsgMessage = _zmsgMessage zmsg <> [zframe]}+addFrame _ _ = throw ZyreMsgDontSupportFramesException++-- {- Interface -}++append :: ZMsg -> ZFrame -> ZMsg+append = addFrame++prepend :: ZMsg -> ZFrame -> ZMsg+prepend = pushFrame++-- | Remove the first frame of a ZMsg, or return 'Nothing'.+pop :: ZMsg -> (Maybe ZFrame, ZMsg)+pop zmsg@Whisper {} = _popMsg zmsg+pop zmsg@Shout {} = _popMsg zmsg+pop _ = throw ZyreMsgDontSupportFramesException++_popMsg :: ZMsg -> (Maybe ZFrame, ZMsg)+_popMsg m = case _zmsgMessage m of+  [] -> (Nothing, m)+  [x] -> (Just x, m {_zmsgMessage = []})+  (x : _) -> (Just x, m {_zmsgMessage = List.tail (_zmsgMessage m)})++-- | Push a text frame to the front of a 'ZMsg'.+pushText :: Text -> ZMsg -> ZMsg+pushText str zmsg = zmsg `pushFrame` ZFrame (fromString (T.unpack str))++-- | Add a text frame to the end of a 'ZMsg'.+addText :: Text -> ZMsg -> ZMsg+addText str zmsg = zmsg `addFrame` ZFrame (fromString (T.unpack str))++-- | Push binary data to the front of a 'ZMsg' as a frame.+pushMem :: ByteString -> ZMsg -> ZMsg+pushMem bs zmsg = zmsg `pushFrame` ZFrame bs++-- | Add binary data to the end of a 'ZMsg' as a frame.+addMem :: ByteString -> ZMsg -> ZMsg+addMem bs zmsg = zmsg `addFrame` ZFrame bs++-- | Remove the first frame of the 'ZMsg', and interpret it as 'Text'.+popText :: ZMsg -> (Maybe Text, ZMsg)+popText zmsg =+  Data.Bifunctor.first+    (fmap (\(ZFrame bs) -> T.pack (BSC.unpack bs)))+    (pop zmsg)++-- | Remove the first frame of the 'ZMsg' as a 'ByteString'.+popMem :: ZMsg -> (Maybe ByteString, ZMsg)+popMem zmsg =+  Data.Bifunctor.first+    (fmap (\(ZFrame bs) -> bs))+    (pop zmsg)++-- | Create a frame from a ByteString.+mkFrame :: ByteString -> ZFrame+mkFrame = ZFrame++-- | Retrieve the data stored in a 'ZFrame'.+frameData :: ZFrame -> ByteString+frameData (ZFrame bs) = bs++-- | Empty 'Whisper' message. Combine with 'addText', 'pushText',+-- 'addMem', and 'pushMem' to construct a whisper to send.+msgWhisper :: ZMsg+msgWhisper =+  Whisper+    { _zmsgFromNode = "Not set",+      _zmsgName = "Not set",+      _zmsgMessage = []+    }++-- | Empty 'Shout' message. Combine with 'addText', 'pushText',+-- 'addMem', and 'pushMem' to construct a shout to send.+msgShout :: ZMsg+msgShout =+  Shout+    { _zmsgFromNode = "Not set",+      _zmsgName = "Not set",+      _zmsgGroupName = "Not set",+      _zmsgMessage = []+    }

+ src/Network/Zyre2/Zyre.hs view

@@ -0,0 +1,502 @@+-- | Zyre provides reliable group messaging over local area networks. It has these key characteristics:+--+-- * Zyre needs no administration or configuration.+-- * Peers may join and leave the network at any time.+-- * Peers talk to each other without any central brokers or servers.+-- * Peers can talk directly to each other.+-- * Peers can join groups, and then talk to groups.+-- * Zyre is reliable, and loses no messages even when the network is heavily loaded.+-- * Zyre is fast and has low latency, requiring no consensus protocols.+-- * Zyre is designed for WiFi networks, yet also works well on Ethernet networks.+-- * Time for a new peer to join a network is about one second.+--+-- Typical use cases for Zyre are:+--+-- * Local service discovery.+-- * Clustering of a set of services on the same Ethernet network.+-- * Controlling a network of smart devices (Internet of Things).+-- * Multi-user mobile applications (like smart classrooms).+--+-- This package provides a haskell interface to the Zyre 2.0 API. The+-- package requires the c libraries czmq and zyre to be installed on the+-- system. See https://github.com/zeromq/zyre for specifics.+module Network.Zyre2.Zyre+  ( name,+    new,+    start,+    stop,+    destroy,+    join,+    leave,+    uuid,+    version,+    shout,+    shouts,+    whisper,+    whispers,+    recv,+    peers,+    peerAddress,+    peerName,+    peerHeaderValue,+    peersByGroup,+    ownGroups,+    peerGroups,+  )+where++import Control.Exception (throw)+import Control.Monad (forM, forM_, unless, void)+import qualified Data.ByteString as BS+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word (Word64)+import Foreign.C.String (newCString, peekCString)+import Foreign.Marshal.Alloc (free)+import Foreign.Ptr (Ptr, nullPtr)+import qualified Network.Zyre2.Bindings as ZB+import Network.Zyre2.Types+  ( ZCreated,+    ZDestroyed,+    ZRunning,+    ZStopped,+    ZyreContext (ZyreContext),+    unlessStale,+  )+import qualified Network.Zyre2.ZMsg as ZM++-- | Create a new Zyre instance/context.+-- All created contexts must be manually cleaned up with 'destroy' to avoid leaks.+-- Takes a node name, or if 'Nothing' will auto-generate a name from the node UUID.+new :: Maybe Text -> IO (ZyreContext ZCreated)+new name = do+  cname <- case name of+    Just t -> newCString (T.unpack t)+    Nothing -> pure nullPtr+  ptr <- ZB.zyreNew cname+  case name of+    Just _ -> free cname+    Nothing -> pure ()+  stale <- newIORef False+  nameMap <- newIORef Map.empty+  let ctx = ZyreContext ptr stale nameMap :: ZyreContext ZCreated+  pure ctx++-- | Start the zyre instance. Starts UDP beaconing and joins the+-- peer network. Generates an 'Enter' message for other participants.+start :: ZyreContext ZCreated -> IO (ZyreContext ZRunning)+start zctx@(ZyreContext ptr stale nameMap) = unlessStale zctx $ do+  void . ZB.zyreStart $ ptr+  newStale <- newIORef False+  let ctx = ZyreContext ptr newStale nameMap :: ZyreContext ZRunning+  atomicModifyIORef' stale (const (True, ()))+  pure ctx++-- | Stop the zyre instance, leaving the peer network.+-- Generates a 'Exit' message for the other participants.+stop :: ZyreContext ZRunning -> IO (ZyreContext ZStopped)+stop zctx@(ZyreContext ptr stale nameMap) = unlessStale zctx $ do+  void . ZB.zyreStop $ ptr+  newStale <- newIORef False+  let ctx = ZyreContext ptr newStale nameMap :: ZyreContext ZStopped+  atomicModifyIORef' stale (const (True, ()))+  pure ctx++-- | Destroy the given zyre context, freeing its resources.+-- Once it has been destroyed, it can no longer be used.+-- Returns a ZyreContext tagged as destroyed to maintain an API+-- similar to the rest of the interface.+destroy :: ZyreContext ZStopped -> IO (ZyreContext ZDestroyed)+destroy zctx@(ZyreContext ptr stale nameMap) = unlessStale zctx $ do+  ZB.zyreDestroy ptr+  let ctx = ZyreContext ptr stale nameMap :: ZyreContext ZDestroyed+  atomicModifyIORef' stale (const (True, ()))+  pure ctx++-- | Join a peer group, to start receiving and be able to send+-- messages from that group. Generates a 'Join' message for+-- the other participants in the group.+join :: ZyreContext ZRunning -> Text -> IO Int+join zctx@(ZyreContext ptr _ _) name = unlessStale zctx $ do+  cname <- newCString (T.unpack name)+  cint <- ZB.zyreJoin ptr cname+  free cname+  pure $ fromIntegral cint++-- | Leave a peer group, and stop receiving updates from that group.+-- Generates a 'Leave' message for the other participants in the+-- group network.+leave :: ZyreContext ZRunning -> Text -> IO Int+leave zctx@(ZyreContext ptr _ _) name = unlessStale zctx $ do+  cname <- newCString (T.unpack name)+  cint <- ZB.zyreLeave ptr cname+  free cname+  pure $ fromIntegral cint++-- | Retrieve the UUID generated for the context.+uuid :: ZyreContext a -> IO Text+uuid zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  cstring <- ZB.zyreUuid ptr+  str <- peekCString cstring <* free cstring+  pure $ T.pack str++-- | Retrieve the version of underlying zyre library.+version :: IO Word64+version = ZB.zyreVersion++-- | Retrieve the name of our node after initialization. Either set by 'new'+-- or automatically generated by zyre from the nodes UUID.+name :: ZyreContext a -> IO Text+name zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  cstring <- ZB.zyreName ptr+  str <- peekCString cstring <* free cstring+  pure $ T.pack str++-- | Shout a 'Shout' to a group. Sends data frames.+--+-- > ctx <- new "my-node"+-- > ctx <- start ctx+-- > join ctx "my-group"+-- > let msg = addString "My message" msgShout+-- > shout ctx "my-group" msg+--+-- You can also send multiple frames in the same message.+--+-- > let msg = addString "Frame2" . addString "Frame1" $ msgShout+shout :: ZyreContext ZRunning -> Text -> ZM.ZMsg -> IO Int+shout zctx@(ZyreContext ptr _ _) room zmsg@ZM.Shout {} = unlessStale zctx $ do+  msg_ptr <- ZB.zyreNewZMsg+  croom <- newCString (T.unpack room)+  forM_ (ZM._zmsgMessage zmsg) $ \frame -> ZB.zyreAddFrame msg_ptr (ZM.frameData frame)+  cint <- ZB.zyreShout ptr croom msg_ptr+  free croom+  pure $ fromIntegral cint+shout _ _ _ = pure (-1)++-- | Shout a 'Shout' to a group. Sends some 'Text' value encoded as a 'Data.ByteString.ByteString'.+--+-- > ctx <- new "my-node"+-- > ctx <- start ctx+-- > join ctx "my-group"+-- > shout ctx "my-group" "My message"+shouts :: ZyreContext ZRunning -> Text -> Text -> IO Int+shouts zctx@(ZyreContext ptr _ _) room msg = unlessStale zctx $ do+  croom <- newCString (T.unpack room)+  cmsg <- newCString (T.unpack msg)+  cint <- ZB.zyreShouts ptr croom cmsg+  free croom+  free cmsg+  pure $ fromIntegral cint++-- | Whisper a 'Whisper' to a specific peer. Takes a node id and a 'ZMsg'. Sends data frames.+whisper :: ZyreContext ZRunning -> Text -> ZM.ZMsg -> IO Int+whisper zctx@(ZyreContext ptr _ _) peer zmsg@ZM.Whisper {} = unlessStale zctx $ do+  msg_ptr <- ZB.zyreNewZMsg+  cpeer <- newCString (T.unpack peer)+  forM_ (ZM._zmsgMessage zmsg) $ \frame -> ZB.zyreAddFrame msg_ptr (ZM.frameData frame)+  cint <- ZB.zyreWhisper ptr cpeer msg_ptr+  free cpeer+  pure $ fromIntegral cint+whisper _ _ _ = pure (-1)++-- | Whisper a 'Whisper' to a specific peer. Sends some 'Text' value encoded as a 'Data.ByteString.ByteString'.+whispers :: ZyreContext ZRunning -> Text -> Text -> IO Int+whispers zctx@(ZyreContext ptr _ _) peer msg = unlessStale zctx $ do+  cpeer <- newCString (T.unpack peer)+  cmsg <- newCString (T.unpack msg)+  cint <- ZB.zyreWhispers ptr cpeer cmsg+  free cpeer+  free cmsg+  pure $ fromIntegral cint++-- | Block and await a message from the peer network.+-- Returns 'Nothing' if it times out or is interruped.+recv :: ZyreContext ZRunning -> IO (Maybe ZM.ZMsg)+recv zctx@(ZyreContext ptr _ nameMap) = unlessStale zctx $ do+  -- Block and listen for a msg, receive a pointer to msg or null.+  ZB.zyreRecv ptr >>= \msg_ptr -> do+    if msg_ptr == nullPtr+      then pure Nothing+      else do+        -- Check first frame for message type+        cmsgType <- ZB.zyrePopStrFrame msg_ptr+        msgType <- peekCString cmsgType <* free cmsgType++        -- Parse remaining frames depending on message type+        maybeMsg <- case msgType of+          "ENTER" -> parseEnterMessage msg_ptr nameMap+          "EVASIVE" -> parseEvasiveMessage msg_ptr+          "SILENT" -> parseSilentMessage msg_ptr+          "EXIT" -> parseExitMessage msg_ptr nameMap+          "JOIN" -> parseJoinMessage msg_ptr+          "LEAVE" -> parseLeaveMessage msg_ptr+          "WHISPER" -> parseWhisperMessage msg_ptr+          "SHOUT" -> parseShoutMessage msg_ptr+          "STOP" -> pure $ Just ZM.Stop++          -- If we encounter an unknown message type+          _ -> do+            putStrLn $ "Unhandled msgType: " <> msgType+            pure Nothing+        -- Clean up zmsg+        ZB.zyreZmsgDestroy msg_ptr+        pure maybeMsg+  where+    parseEnterMessage msg_ptr nameMap = do+      -- Pop the message metadata off the zmsg, marshal into haskell types.+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      cheader_ptr <- ZB.zyrePopFrame msg_ptr+      cipport <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname  <* free cname+      ipport <- peekCString cipport <* free cipport++      -- Unpack the headers+      headersRef <- newIORef []+      headers_ptr <- ZB.zyreUnpackHeaders cheader_ptr+      extractHeaders headers_ptr headersRef+      ZB.zyreDestroyHeaders headers_ptr+      headers <- readIORef headersRef++      -- Release the allocated resources+      ZB.zyreDestroyFrame cheader_ptr++      -- Add the node name to our mapping+      atomicModifyIORef' nameMap (\x -> (Map.insert (T.pack fromnode) (T.pack name) x, ()))++      pure $+        Just $+          ZM.Enter+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name,+              ZM._zmsgHeaders = headers,+              ZM._zmsgIpPort = T.pack ipport+            }++    parseEvasiveMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname++      pure $+        Just $+          ZM.Evasive+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name+            }++    parseSilentMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname++      pure $+        Just $+          ZM.Silent+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name+            }++    parseExitMessage msg_ptr nameMap = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname++      -- Remove the node name from our mapping+      atomicModifyIORef' nameMap (\x -> (Map.delete (T.pack fromnode) x, ()))++      pure $+        Just $+          ZM.Exit+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name+            }++    parseJoinMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      cgroupname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname+      groupname <- peekCString cgroupname <* free cgroupname++      pure $+        Just $+          ZM.Join+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name,+              ZM._zmsgGroupName = T.pack groupname+            }++    parseLeaveMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      cgroupname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname+      groupname <- peekCString cgroupname <* free cgroupname++      pure $+        Just $+          ZM.Leave+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name,+              ZM._zmsgGroupName = T.pack groupname+            }++    parseWhisperMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname++      msgBodyRef <- newIORef []+      extractFrames msg_ptr msgBodyRef+      msgBody <- readIORef msgBodyRef++      pure $+        Just $+          ZM.Whisper+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name,+              ZM._zmsgMessage = msgBody+            }++    parseShoutMessage msg_ptr = do+      cfromnode <- ZB.zyrePopStrFrame msg_ptr+      cname <- ZB.zyrePopStrFrame msg_ptr+      cgroupname <- ZB.zyrePopStrFrame msg_ptr+      fromnode <- peekCString cfromnode <* free cfromnode+      name <- peekCString cname <* free cname+      groupname <- peekCString cgroupname <* free cgroupname++      msgBodyRef <- newIORef []+      extractFrames msg_ptr msgBodyRef+      msgBody <- readIORef msgBodyRef++      pure $+        Just $+          ZM.Shout+            { ZM._zmsgFromNode = T.pack fromnode,+              ZM._zmsgName = T.pack name,+              ZM._zmsgGroupName = T.pack groupname,+              ZM._zmsgMessage = msgBody+            }++-- | List the id of the peers in the peer network.+peers :: ZyreContext ZRunning -> IO [Text]+peers zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  list_ptr <- ZB.zyrePeers ptr+  returnRef <- newIORef []+  extractList list_ptr returnRef+  ZB.zyreZListDestroy list_ptr+  readIORef returnRef++-- | List the id of the peers in a specific group in the peer network.+peersByGroup :: ZyreContext ZRunning -> Text -> IO (Maybe [Text])+peersByGroup zctx@(ZyreContext ptr _ _) group = unlessStale zctx $ do+  returnRef <- newIORef []+  cgroup <- newCString (T.unpack group)+  list_ptr <- ZB.zyrePeersByGroup ptr cgroup+  if list_ptr /= nullPtr+    then do+      extractList list_ptr returnRef+      ZB.zyreZListDestroy list_ptr+    else pure ()+  free cgroup+  (\xs -> if null xs then Nothing else Just xs) <$> readIORef returnRef++-- | Retrieve the endpoint of a connected peer.+-- Returns 'Nothing' if peer does not exist.+peerAddress :: ZyreContext ZRunning -> Text -> IO (Maybe Text)+peerAddress zctx@(ZyreContext ptr _ _) peer = unlessStale zctx $ do+  cpeer <- newCString (T.unpack peer)+  caddress <- ZB.zyrePeerAddress ptr cpeer+  address <- T.pack <$> peekCString caddress+  free cpeer+  free caddress+  pure $ if T.null address then Nothing else Just address++peerName :: ZyreContext ZRunning -> Text -> IO (Maybe Text)+peerName zctx@(ZyreContext _ _ nameMap) peer = unlessStale zctx $ do+  map <- readIORef nameMap+  pure $ Map.lookup peer map++-- | Retrieve the value of a header of a connected peer.+-- Returns 'Nothing' if peer or key doesn't exist.+peerHeaderValue :: ZyreContext ZRunning -> Text -> Text -> IO (Maybe Text)+peerHeaderValue zctx@(ZyreContext ptr _ _) peer header = unlessStale zctx $ do+  cpeer <- newCString (T.unpack peer)+  cheader <- newCString (T.unpack header)+  cvalue <- ZB.zyrePeerHeaderValue ptr cpeer cheader+  value <- if cvalue == nullPtr then pure T.empty else T.pack <$> peekCString cvalue+  free cpeer+  free cheader+  free cvalue+  pure $ if T.null value then Nothing else Just value++-- | List the groups that you are a part of.+ownGroups :: ZyreContext ZRunning -> IO [Text]+ownGroups zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  list_ptr <- ZB.zyreOwnGroups ptr+  returnRef <- newIORef []+  extractList list_ptr returnRef+  ZB.zyreZListDestroy list_ptr+  readIORef returnRef++-- | List groups that are known through connected peers.+peerGroups :: ZyreContext ZRunning -> IO [Text]+peerGroups zctx@(ZyreContext ptr _ _) = unlessStale zctx $ do+  list_ptr <- ZB.zyreOwnGroups ptr+  returnRef <- newIORef []+  extractList list_ptr returnRef+  ZB.zyreZListDestroy list_ptr+  readIORef returnRef++-- | Internal helper function.+-- Traverses a zmsg using next() and accumulates the frames in an IORef.+extractFrames :: Ptr () -> IORef [ZM.ZFrame] -> IO ()+extractFrames msg_ptr framesRef = do+  cursor <- ZB.zyreNextFrame msg_ptr+  if cursor /= nullPtr+    then do+      len <- ZB.zyreFrameSize cursor+      content_ptr <- ZB.zyreFrameData cursor+      packed <- BS.packCStringLen (content_ptr, fromIntegral len)+      atomicModifyIORef' framesRef (\x -> (x <> [ZM.mkFrame packed], ()))+      extractFrames msg_ptr framesRef+    else pure ()++-- | Internal helper function.+-- Traverses an unpacked zhash table, using next() and cursor() to+-- accumulate the stored values into a dictionary in an IORef.+extractHeaders :: Ptr () -> IORef [(Text, Text)] -> IO ()+extractHeaders header_ptr headersRef = do+  cursor <- ZB.zyreNextHeader header_ptr+  if cursor /= nullPtr+    then do+      key_ptr <- ZB.zyreHeaderCursor header_ptr+      key <- peekCString key_ptr+      val <- peekCString cursor++      atomicModifyIORef' headersRef (\x -> (x <> [(T.pack key, T.pack val)], ()))+      extractHeaders header_ptr headersRef+    else pure ()++-- | Internal helper function.+-- Extracts values in a zlist as text values into an IORef.+extractList :: Ptr () -> IORef [Text] -> IO ()+extractList list_ptr accumRef = do+  cursor <- ZB.zyreZListNext list_ptr+  if cursor /= nullPtr+    then do+      val <- peekCString cursor+      atomicModifyIORef' accumRef (\x -> (x <> [T.pack val], ()))+      extractList list_ptr accumRef+    else pure ()

+ stack.yaml view

@@ -0,0 +1,67 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# https://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+#+# The location of a snapshot can be provided as a file or url. Stack assumes+# a snapshot provided as a file might change, whereas a url resource does not.+#+# resolver: ./custom-snapshot.yaml+# resolver: https://example.com/snapshots/2018-01-01.yaml+resolver:+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+#   subdirs:+#   - auto-update+#   - wai+packages:+- .+# Dependency packages to be pulled from upstream that are not in the resolver.+# These entries can reference officially published versions as well as+# forks / in-progress versions pinned to a git hash. For example:+#+# extra-deps:+# - acme-missiles-0.3+# - git: https://github.com/commercialhaskell/stack.git+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+#+# extra-deps: []++# Override default flag values for local packages and extra-deps+# flags: {}++# Extra package databases containing global packages+# extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=2.7"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"

+ zyre2.cabal view

@@ -0,0 +1,84 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           zyre2+version:        0.1.1.0+synopsis:       Haskell zyre bindings for reliable group messaging over local area networks.+description:    Please see the README on GitHub at <https://github.com/skrioify/haskell-zyre2#readme>+category:       Web+homepage:       https://github.com/skrioify/haskell-zyre2#readme+bug-reports:    https://github.com/skrioify/haskell-zyre2/issues+author:         Emil Nylind+maintainer:     emil@nylind.se+copyright:      2022 Emil Nylind+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/skrioify/haskell-zyre2++library+  exposed-modules:+      Network.Zyre2+      Network.Zyre2.Configuration+  other-modules:+      Network.Zyre2.Bindings+      Network.Zyre2.Types+      Network.Zyre2.ZMsg+      Network.Zyre2.Zyre+      Paths_zyre2+  hs-source-dirs:+      src+  extra-lib-dirs:+      /usr/local/lib+  extra-libraries:+      zyre+      czmq+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10.12 && <0.11+    , containers >=0.6.5 && <0.7+    , inline-c >=0.9.1 && <0.10+    , text >=1.2.4 && <1.3+  default-language: Haskell2010++executable zyre-example-exe+  main-is: Main.hs+  other-modules:+      Paths_zyre2+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10.12 && <0.11+    , containers >=0.6.5 && <0.7+    , inline-c >=0.9.1 && <0.10+    , text >=1.2.4 && <1.3+    , zyre2+  default-language: Haskell2010++test-suite zyre2-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_zyre2+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10.12 && <0.11+    , containers >=0.6.5 && <0.7+    , inline-c >=0.9.1 && <0.10+    , text >=1.2.4 && <1.3+    , zyre2+  default-language: Haskell2010