├── Setup.hs
├── .gitignore
├── cabal.project
├── CONTRIBUTORS
├── tests
    ├── Main.hs
    ├── Properties.hs
    └── BinaryProperties.hs
├── changelog
├── flake.nix
├── benchmarks
    ├── SendMessages.hs
    └── Zmq.hs
├── LICENSE
├── flake.lock
├── src
    ├── Nanomsg
    │   └── Binary.hs
    └── Nanomsg.hsc
├── README.md
├── nanomsg-haskell.cabal
└── .github
    └── workflows
        └── haskell-ci.yml


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | /.cabal-sandbox/
2 | /cabal.sandbox.config
3 | /cabal-dev
4 | /dist
5 | *.swp
6 | /dist-newstyle
7 | 


--------------------------------------------------------------------------------
/cabal.project:
--------------------------------------------------------------------------------
1 | packages: .
2 | tests: true
3 | 
4 | package nanomsg-haskell
5 |   test-options: --num-threads=1
6 | 


--------------------------------------------------------------------------------
/CONTRIBUTORS:
--------------------------------------------------------------------------------
1 | Ivar Nymoen <ivar dot nymoen at gmail dot com>
2 | João Cristóvão <jmacristovao at gmail dot com>
3 | Jakub Stasiak <jakub at stasiak dot at>
4 | Will Martino <wjmartino at gmail dot com>
5 | Ben Gamari
6 | 


--------------------------------------------------------------------------------
/tests/Main.hs:
--------------------------------------------------------------------------------
 1 | import qualified Test.Tasty as T
 2 | import qualified Test.Tasty.Ingredients as T
 3 | 
 4 | import qualified BinaryProperties
 5 | import qualified Properties
 6 | 
 7 | tests :: T.TestTree
 8 | tests =
 9 |     T.sequentialTestGroup "tests" T.AllFinish
10 |       [ Properties.tests
11 |       , BinaryProperties.tests
12 |       ]
13 | 
14 | ingredients :: [T.Ingredient]
15 | ingredients = T.defaultIngredients
16 | 
17 | main :: IO ()
18 | main = do
19 |     T.defaultMainWithIngredients ingredients tests
20 | 
21 | 


--------------------------------------------------------------------------------
/changelog:
--------------------------------------------------------------------------------
 1 | 0.2.5
 2 |   * Deprecate `NN_LINGER` option
 3 |   * Improve testsuite reliability
 4 |   * Add support for `NN_RCVMAXSIZE` option
 5 |   * Fixed bug in nonblocking send where `threadWaitWrite` was used instead of
 6 |     `threadWaitRead`
 7 | 
 8 | 0.2.4
 9 |   * Bumped upper bound on binary
10 | 
11 | 0.2.3
12 |   * Switched to safe ffi calls to play better with the runtime
13 |   * Tests fixed for ghc 7.10
14 |   * Some minor tweaks to docs and metadata
15 | 
16 | 0.2.2
17 |   * Added a thin Binary based serialization layer
18 |   * Benchmarks now depend on ZMQ4
19 | 
20 | 


--------------------------------------------------------------------------------
/flake.nix:
--------------------------------------------------------------------------------
 1 | {
 2 |   description = "nanomsg-haskell";
 3 | 
 4 |   inputs.flake-utils.url = "github:numtide/flake-utils";
 5 | 
 6 |   outputs = { self, nixpkgs, flake-utils }:
 7 |     flake-utils.lib.eachDefaultSystem (system:
 8 |       let pkgs = nixpkgs.legacyPackages.${system}; in
 9 |       {
10 |         devShells.default = pkgs.mkShell {
11 |           packages = with pkgs; [ nanomsg ];
12 |         };
13 |         packages = rec {
14 |           default = pkgs.haskellPackages.callCabal2nix "nanomsg-haskell" ./. {
15 |             nanomsg = pkgs.nanomsg;
16 |           };
17 |         };
18 |       }
19 |     );
20 | }
21 | 


--------------------------------------------------------------------------------
/benchmarks/SendMessages.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import Nanomsg
 4 | import Criterion.Main
 5 | import qualified Data.ByteString.Char8 as C
 6 | import Control.Monad (replicateM_)
 7 | 
 8 | pair :: Int -> Int -> IO ()
 9 | pair size count = do
10 |     sender <- socket Pair
11 |     _ <- bind sender "inproc://pairtest"
12 |     recipient <- socket Pair
13 |     _ <- connect recipient "inproc://pairtest"
14 |     let msg = C.pack $ replicate size 'a'
15 |     replicateM_ count (send sender msg >> recv recipient)
16 |     close sender
17 |     close recipient
18 |     return ()
19 | 
20 | main :: IO ()
21 | main = defaultMain
22 |     [ bench "40 bytes x 10k messages" $ nfIO $ pair    40 10000
23 |     , bench "20k bytes x 20 messages" $ nfIO $ pair 20000    20
24 |     ]
25 | 
26 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | 
 2 | Copyright (c) 2013 the nanomsg-haskell authors
 3 | 
 4 | Permission is hereby granted, free of charge, to any person obtaining a copy
 5 | of this software and associated documentation files (the "Software"), to deal
 6 | in the Software without restriction, including without limitation the rights
 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 8 | copies of the Software, and to permit persons to whom the Software is
 9 | furnished to do so, subject to the following conditions:
10 | 
11 | The above copyright notice and this permission notice shall be included in
12 | all copies or substantial portions of the Software.
13 | 
14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
20 | THE SOFTWARE.
21 | 


--------------------------------------------------------------------------------
/flake.lock:
--------------------------------------------------------------------------------
 1 | {
 2 |   "nodes": {
 3 |     "flake-utils": {
 4 |       "inputs": {
 5 |         "systems": "systems"
 6 |       },
 7 |       "locked": {
 8 |         "lastModified": 1731533236,
 9 |         "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
10 |         "owner": "numtide",
11 |         "repo": "flake-utils",
12 |         "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
13 |         "type": "github"
14 |       },
15 |       "original": {
16 |         "owner": "numtide",
17 |         "repo": "flake-utils",
18 |         "type": "github"
19 |       }
20 |     },
21 |     "nixpkgs": {
22 |       "locked": {
23 |         "lastModified": 1744998416,
24 |         "narHash": "sha256-EC4LLF55Lv3ccnpwO1hXrk4rsF4+yuLW2QlZI7N5vLY=",
25 |         "path": "/nix/store/q28jhpvr84nbiyi0rdmr3mnh3gh646ps-source",
26 |         "rev": "21454c534a05a2e6a5819898b457ff31b2becbdc",
27 |         "type": "path"
28 |       },
29 |       "original": {
30 |         "id": "nixpkgs",
31 |         "type": "indirect"
32 |       }
33 |     },
34 |     "root": {
35 |       "inputs": {
36 |         "flake-utils": "flake-utils",
37 |         "nixpkgs": "nixpkgs"
38 |       }
39 |     },
40 |     "systems": {
41 |       "locked": {
42 |         "lastModified": 1681028828,
43 |         "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
44 |         "owner": "nix-systems",
45 |         "repo": "default",
46 |         "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
47 |         "type": "github"
48 |       },
49 |       "original": {
50 |         "owner": "nix-systems",
51 |         "repo": "default",
52 |         "type": "github"
53 |       }
54 |     }
55 |   },
56 |   "root": "root",
57 |   "version": 7
58 | }
59 | 


--------------------------------------------------------------------------------
/src/Nanomsg/Binary.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
 2 | -- |
 3 | -- Module:          Nanomsg.Binary
 4 | --
 5 | -- This module offers a thin serialization layer ("Binary" based)
 6 | -- over @'send'@ and @'receive'@. You just need to import 
 7 | -- @Nanomsg.Binary@ instead of @Nanomsg@.
 8 | 
 9 | module Nanomsg.Binary
10 |   (
11 |   -- * Types
12 |   -- ** Socket types
13 |     Pair(..)
14 |   , Req(..)
15 |   , Rep(..)
16 |   , Pub(..)
17 |   , Sub(..)
18 |   , Surveyor(..)
19 |   , Respondent(..)
20 |   , Push(..)
21 |   , Pull(..)
22 |   , Bus(..)
23 |   -- ** Other
24 |   , Socket
25 |   , Endpoint
26 |   , NNException
27 | --  , eTERM
28 | --  , eFSM
29 |   , SocketType
30 |   , Sender
31 |   , Receiver
32 |   -- * Operations
33 |   -- ** General operations
34 |   , socket
35 |   , withSocket
36 |   , bind
37 |   , connect
38 |   , send
39 |   , recv
40 |   , recv'
41 |   , subscribe
42 |   , unsubscribe
43 |   , shutdown
44 |   , close
45 |   , term
46 |   -- ** Socket option settings
47 |   , linger
48 |   , setLinger
49 |   , sndBuf
50 |   , setSndBuf
51 |   , rcvBuf
52 |   , setRcvBuf
53 |   , reconnectInterval
54 |   , setReconnectInterval
55 |   , reconnectIntervalMax
56 |   , setReconnectIntervalMax
57 |   , sndPrio
58 |   , setSndPrio
59 |   , ipv4Only
60 |   , setIpv4Only
61 |   , requestResendInterval
62 |   , setRequestResendInterval
63 |   , surveyorDeadline
64 |   , setSurveyorDeadline
65 |   , tcpNoDelay
66 |   , setTcpNoDelay
67 | 
68 |   ) where
69 | 
70 | import Control.Applicative
71 | import Nanomsg hiding (send,recv,recv')
72 | import qualified Nanomsg as NM
73 | import Data.Binary
74 | import Data.ByteString.Lazy
75 | 
76 | send
77 |   :: (Sender s, Binary dat)
78 |   => Socket s
79 |   -> dat
80 |   -> IO ()
81 | send s d = NM.send s (toStrict . encode $ d)
82 | 
83 | recv
84 |   :: (Receiver s, Binary dat)
85 |   => Socket s
86 |   -> IO dat
87 | recv s = decode . fromStrict <$> NM.recv s
88 | 
89 | recv'
90 |   :: (Receiver s, Binary dat)
91 |   => Socket s
92 |   -> IO (Maybe dat)
93 | recv' s = fmap (decode . fromStrict) <$> NM.recv' s
94 | 
95 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # nanomsg-haskell
 2 | 
 3 | This is a Haskell binding for the nanomsg library: <http://nanomsg.org/>.
 4 | 
 5 | There's support for [(evented)](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Concurrent.html#v:threadWaitRead) blocking send and recv, a non-blocking receive,
 6 | and for all the socket types and the functions you need to wire them up and
 7 | tear them down again.
 8 | 
 9 | Most socket options are available through accessor and mutator
10 | functions. Sockets are typed, transports are not.
11 | 
12 | 
13 | ## Building
14 | 
15 | You would normally make sure the nanomsg library is on your system and then
16 | install from Hackage, but can build from source following these steps:
17 | 
18 |   1. Build and install nanomsg (and zeromq, if you are building benchmarks)
19 |   1. git clone https://github.com/ivarnymoen/nanomsg-haskell
20 |   1. cd nanomsg-haskell && cabal sandbox init
21 |   1. cabal install --dependencies-only [--enable-tests] [--enable-benchmarks]
22 |   1. cabal configure [--enable-tests] [--enable-benchmarks]
23 |   1. cabal build
24 |   1. [cabal test]
25 | 
26 | 
27 | ## Usage
28 | 
29 | Simple pub/sub example:
30 | 
31 | Server:
32 | ```haskell
33 | module Main where
34 | 
35 | import Nanomsg
36 | import qualified Data.ByteString.Char8 as C
37 | import Control.Monad (mapM_)
38 | import Control.Concurrent (threadDelay)
39 | 
40 | main :: IO ()
41 | main =
42 |     withSocket Pub $ \s -> do
43 |         _ <- bind s "tcp://*:5560"
44 |         mapM_ (\num -> sendNumber s num) (cycle [1..1000000 :: Int])
45 |     where
46 |         sendNumber s number = do
47 |             threadDelay 1000        -- let's conserve some cycles
48 |             let numAsString = show number
49 |             send s (C.pack numAsString)
50 | ```
51 | 
52 | Client:
53 | ```haskell
54 | module Main where
55 | 
56 | import Nanomsg
57 | import qualified Data.ByteString.Char8 as C
58 | import Control.Monad (forever)
59 | 
60 | main :: IO ()
61 | main =
62 |     withSocket Sub $ \s -> do
63 |         _ <- connect s "tcp://localhost:5560"
64 |         subscribe s $ C.pack ""
65 |         forever $ do
66 |             msg <- recv s
67 |             C.putStrLn msg
68 | ```
69 | 
70 | Nonblocking client:
71 | ```haskell
72 | module Main where
73 | 
74 | import Nanomsg
75 | import qualified Data.ByteString.Char8 as C
76 | import Control.Monad (forever)
77 | import Control.Concurrent (threadDelay)
78 | 
79 | main :: IO ()
80 | main =
81 |     withSocket Sub $ \s -> do
82 |         _ <- connect s "tcp://localhost:5560"
83 |         subscribe s $ C.pack ""
84 |         forever $ do
85 |             threadDelay 700           -- let's conserve some cycles
86 |             msg <- recv' s
87 |             C.putStrLn $ case msg of
88 |                 Nothing -> C.pack "No message"
89 |                 Just m  -> m
90 | ```
91 | 


--------------------------------------------------------------------------------
/nanomsg-haskell.cabal:
--------------------------------------------------------------------------------
 1 | name:                nanomsg-haskell
 2 | version:             0.2.5
 3 | synopsis:
 4 |   Bindings to the nanomsg library
 5 | description:
 6 |   This is a Haskell binding for the nanomsg library: <http://nanomsg.org/>.
 7 |   .
 8 |   There's support for (evented) blocking send and recv, a non-blocking receive,
 9 |   and for all the socket types and the functions you need to wire
10 |   them up and tear them down again.
11 |   .
12 |   Most sockets options are available through accessor and mutator
13 |   functions. Sockets are typed, transports are not.
14 | 
15 | homepage:            https://github.com/ivarnymoen/nanomsg-haskell
16 | license:             MIT
17 | license-file:        LICENSE
18 | author:              Ivar Nymoen
19 | maintainer:          Ben Gamari <ben@smart-cactus.org>
20 | copyright:           Copyright (c) 2013 the nanomsg-haskell authors
21 | category:            Network
22 | build-type:          Simple
23 | cabal-version:       >=1.10
24 | tested-with:
25 |   GHC == 9.4.7,
26 |   GHC == 9.6.5,
27 |   GHC == 9.8.2,
28 |   GHC == 9.10.1,
29 |   GHC == 9.12.2
30 | extra-source-files:
31 |   README.md
32 |   , CONTRIBUTORS
33 |   , changelog
34 |   , tests/*.hs
35 |   , benchmarks/*.hs
36 | 
37 | library
38 |   hs-source-dirs:    src
39 |   ghc-options:       -O2 -Wall -fwarn-tabs
40 |   default-language:  Haskell2010
41 |   exposed-modules:
42 |     Nanomsg
43 |     Nanomsg.Binary
44 |   default-extensions:  ForeignFunctionInterface, DeriveDataTypeable
45 |   includes:          nanomsg/nn.h
46 |   extra-libraries:   nanomsg
47 |   build-depends:
48 |     base >= 4.5 && < 5,
49 |     bytestring >= 0.9.0 && < 0.13,
50 |     binary >= 0.7 && < 0.9
51 | 
52 | test-suite tests
53 |   type:              exitcode-stdio-1.0
54 |   hs-source-dirs:    tests
55 |   main-is:           Main.hs
56 |   other-modules:     BinaryProperties Properties
57 |   ghc-options:       -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts
58 |   default-language:  Haskell2010
59 |   build-depends:
60 |     base >= 4.5 && < 5,
61 |     bytestring >= 0.9.0 && < 0.13,
62 |     nanomsg-haskell,
63 |     QuickCheck,
64 |     tasty,
65 |     tasty-quickcheck
66 | 
67 | source-repository head
68 |   type:              git
69 |   location:          https://github.com/ivarnymoen/nanomsg-haskell
70 | 
71 | benchmark send-messages
72 |   type:              exitcode-stdio-1.0
73 |   main-is:           SendMessages.hs
74 |   ghc-options:       -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts
75 |   default-language:  Haskell2010
76 |   hs-source-dirs:    benchmarks
77 |   build-depends:
78 |     base >= 4.5 && < 5,
79 |     bytestring >= 0.9.0 && < 0.13,
80 |     nanomsg-haskell,
81 |     criterion
82 | 
83 | benchmark vs-zeromq-bindings
84 |   type:              exitcode-stdio-1.0
85 |   main-is:           Zmq.hs
86 |   ghc-options:       -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts
87 |   default-language:  Haskell2010
88 |   hs-source-dirs:    benchmarks
89 |   build-depends:
90 |     base >= 4.5 && < 5,
91 |     bytestring >= 0.9.0 && < 0.13,
92 |     nanomsg-haskell,
93 |     zeromq4-haskell,
94 |     criterion
95 | 
96 | 


--------------------------------------------------------------------------------
/benchmarks/Zmq.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import qualified Nanomsg as N
 4 | import qualified System.ZMQ4.Monadic as Z
 5 | import Criterion.Main
 6 | import qualified Data.ByteString.Char8 as C
 7 | import Control.Monad (replicateM_)
 8 | 
 9 | nLat :: Int -> Int -> String -> String -> IO ()
10 | nLat size count bindString connString = do
11 |     s1 <- N.socket N.Pair
12 |     _ <- N.bind s1 bindString
13 |     s2 <- N.socket N.Pair
14 |     _ <- N.connect s2 connString
15 |     let msg = C.pack $ replicate size 'a'
16 |     replicateM_ count (N.send s1 msg >> N.recv s2 >>= N.send s2 >> N.recv s1)
17 |     N.close s1
18 |     N.close s2
19 |     return ()
20 | 
21 | zLat :: Int -> Int -> String -> String -> IO ()
22 | zLat size count bindString connString = Z.runZMQ $ do
23 |     s1 <- Z.socket Z.Pair
24 |     _ <- Z.bind s1 bindString
25 |     s2 <- Z.socket Z.Pair
26 |     _ <- Z.connect s2 connString
27 |     let msg = C.pack $ replicate size 'a'
28 |     replicateM_ count (Z.send s1 [] msg >> Z.receive s2 >>= Z.send s2 [] >> Z.receive s1)
29 |     Z.close s1
30 |     Z.close s2
31 |     return ()
32 | 
33 | nThr :: Int -> Int -> String -> String -> IO ()
34 | nThr size count bindString connString = do
35 |     s1 <- N.socket N.Pair
36 |     _ <- N.bind s1 bindString
37 |     s2 <- N.socket N.Pair
38 |     _ <- N.connect s2 connString
39 |     let msg = C.pack $ replicate size 'a'
40 |     replicateM_ count (replicateM_ 100 (N.send s1 msg) >> replicateM_ 100 (N.recv s2))
41 |     N.close s1
42 |     N.close s2
43 |     return ()
44 | 
45 | zThr :: Int -> Int -> String -> String -> IO ()
46 | zThr size count bindString connString = Z.runZMQ $ do
47 |     s1 <- Z.socket Z.Pair
48 |     _ <- Z.bind s1 bindString
49 |     s2 <- Z.socket Z.Pair
50 |     _ <- Z.connect s2 connString
51 |     let msg = C.pack $ replicate size 'a'
52 |     replicateM_ count (replicateM_ 100 (Z.send s1 [] msg) >> replicateM_ 100 (Z.receive s2))
53 |     Z.close s1
54 |     Z.close s2
55 |     return ()
56 | 
57 | main :: IO ()
58 | main = defaultMain
59 |     [ bench "nanomsg-haskell: 40 bytes x 2k messages, lat, tcp"     $ nfIO $ nLat    40 1000 "tcp://*:5566" "tcp://localhost:5566"
60 |     , bench "zeromq4-haskell: 40 bytes x 2k messages, lat, tcp"     $ nfIO $ zLat    40 1000 "tcp://*:5566" "tcp://localhost:5566"
61 |     , bench "nanomsg-haskell: 20k bytes x 40 messages, lat, tcp"    $ nfIO $ nLat 20000   20 "tcp://*:5566" "tcp://localhost:5566"
62 |     , bench "zeromq4-haskell: 20k bytes x 40 messages, lat, tcp"    $ nfIO $ zLat 20000   20 "tcp://*:5566" "tcp://localhost:5566"
63 |     , bench "nanomsg-haskell: 40 bytes x 2k messages, lat, inproc"  $ nfIO $ nLat    40 1000 "inproc://bench" "inproc://bench"
64 |     , bench "zeromq4-haskell: 40 bytes x 2k messages, lat, inproc"  $ nfIO $ zLat    40 1000 "inproc://bench" "inproc://bench"
65 |     , bench "nanomsg-haskell: 20k bytes x 40 messages, lat, inproc" $ nfIO $ nLat 20000   20 "inproc://bench" "inproc://bench"
66 |     , bench "zeromq4-haskell: 20k bytes x 40 messages, lat, inproc" $ nfIO $ zLat 20000   20 "inproc://bench" "inproc://bench"
67 |     , bench "nanomsg-haskell: 40 bytes x 10k messages, throughput, tcp"     $ nfIO $ nThr 40 100 "tcp://*:5566" "tcp://localhost:5566"
68 |     , bench "zeromq4-haskell: 40 bytes x 10k messages, throughput, tcp"     $ nfIO $ zThr 40 100 "tcp://*:5566" "tcp://localhost:5566"
69 |     , bench "nanomsg-haskell: 40 bytes x 10k messages, throughput, inproc"  $ nfIO $ nThr 40 100 "inproc://bench" "inproc://bench"
70 |     , bench "zeromq4-haskell: 40 bytes x 10k messages, throughput, inproc"  $ nfIO $ zThr 40 100 "inproc://bench" "inproc://bench"
71 |     ]
72 | 
73 | 


--------------------------------------------------------------------------------
/tests/Properties.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ScopedTypeVariables #-}
  2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  3 | module Properties where
  4 | 
  5 | import Nanomsg
  6 | import Test.QuickCheck
  7 | import Test.QuickCheck.Monadic
  8 | import Test.Tasty (TestTree, sequentialTestGroup, DependencyType(AllFinish))
  9 | import Test.Tasty.QuickCheck (testProperty)
 10 | import Data.ByteString (ByteString)
 11 | import qualified Data.ByteString.Char8 as C
 12 | import Control.Concurrent (threadDelay)
 13 | import Control.Applicative ( (<$>) )
 14 | import Data.Maybe (catMaybes)
 15 | 
 16 | instance Arbitrary ByteString where
 17 |     arbitrary = C.pack <$> arbitrary
 18 | 
 19 | -- dummy test
 20 | prop_reverse :: [Int] -> Bool
 21 | prop_reverse xs =
 22 |     xs == reverse (reverse xs)
 23 | 
 24 | -- test Pub and Sub sockets
 25 | prop_PubSub :: Property
 26 | prop_PubSub = monadicIO $ do
 27 |     (msgs :: [ByteString]) <- pick arbitrary
 28 |     pre $ not (null msgs)
 29 |     res <- run $ do
 30 |         pub <- socket Pub
 31 |         ep1 <- bind pub "inproc://pubsub"
 32 |         sub1 <- socket Sub
 33 |         ep2 <- connect sub1 "inproc://pubsub"
 34 |         subscribe sub1 $ C.pack ""
 35 |         sub2 <- socket Sub
 36 |         ep3 <- connect sub2 "inproc://pubsub"
 37 |         subscribe sub2 $ C.pack ""
 38 |         threadDelay 1000
 39 |         r <- mapM (sendMsg pub sub1 sub2) msgs
 40 |         unsubscribe sub2 $ C.pack ""
 41 |         unsubscribe sub1 $ C.pack ""
 42 |         shutdown sub2 ep3
 43 |         shutdown sub1 ep2
 44 |         shutdown pub ep1
 45 |         close pub
 46 |         close sub1
 47 |         close sub2
 48 |         threadDelay 1000
 49 |         return r
 50 |     assert $ and res
 51 |         where
 52 |             sendMsg pub sub1 sub2 msg = do
 53 |                 send pub msg
 54 |                 send pub msg
 55 |                 a <- recv sub1
 56 |                 b <- recv sub1
 57 |                 c <- recv sub2
 58 |                 d <- recv sub2
 59 |                 return $ a == msg && b == msg && c == msg && d == msg
 60 | 
 61 | -- test Pair sockets
 62 | prop_Pair :: Property
 63 | prop_Pair = monadicIO $ do
 64 |     (msgs :: [ByteString]) <- pick arbitrary
 65 |     pre $ not (null msgs)
 66 |     res <- run $ do
 67 |         s1 <- socket Pair
 68 |         _ <- bind s1 "inproc://pair"
 69 |         s2 <- socket Pair
 70 |         _ <- connect s2 "inproc://pair"
 71 |         threadDelay 1000
 72 |         -- Send message from s1 to s2, then back from s2 to s1, then make sure it hasn't changed
 73 |         r <- mapM (\m -> send s1 m >> recv s2 >>= send s2 >> recv s1 >>= return . (== m)) msgs
 74 |         close s1
 75 |         close s2
 76 |         threadDelay 1000
 77 |         return r
 78 |     assert $ and res
 79 | 
 80 | -- test Pipeline (Push & Pull) sockets
 81 | prop_Pipeline :: Property
 82 | prop_Pipeline = monadicIO $ do
 83 |     (msgs :: [ByteString]) <- pick arbitrary
 84 |     pre $ not (null msgs)
 85 |     res <- run $ do
 86 |         push <- socket Push
 87 |         _ <- bind push "inproc://pipeline"
 88 |         pull1 <- socket Pull
 89 |         pull2 <- socket Pull
 90 |         _ <- connect pull1 "inproc://pipeline"
 91 |         _ <- connect pull2 "inproc://pipeline"
 92 |         threadDelay 1000
 93 |         r <- mapM (testSockets push pull1 pull2) msgs
 94 |         close push
 95 |         close pull1
 96 |         close pull2
 97 |         threadDelay 1000
 98 |         return r
 99 |     assert $ and res
100 |         where
101 |             testSockets push pull1 pull2 msg = do
102 |                 send push msg
103 |                 send push msg
104 |                 send push msg
105 |                 threadDelay 1000
106 |                 a <- recv' pull1
107 |                 b <- recv' pull1
108 |                 c <- recv' pull1
109 |                 d <- recv' pull2
110 |                 e <- recv' pull2
111 |                 f <- recv' pull2
112 |                 let xs = catMaybes [a, b, c, d, e, f]
113 |                 return $ all (== msg) xs && (length xs == 3)
114 | 
115 | -- test Req and Rep sockets
116 | prop_ReqRep :: Property
117 | prop_ReqRep = monadicIO $ do
118 |     (msgs :: [ByteString]) <- pick arbitrary
119 |     pre $ not (null msgs)
120 |     res <- run $ do
121 |         req <- socket Req
122 |         _ <- bind req "inproc://reqrep"
123 |         rep <- socket Rep
124 |         _ <- connect rep "inproc://reqrep"
125 |         threadDelay 1000
126 |         r <- mapM (\m -> send req m >> recv rep >>= send rep >> recv req >>= return . (== m)) msgs
127 |         close req
128 |         close rep
129 |         threadDelay 1000
130 |         return r
131 |     assert $ and res
132 | 
133 | -- test Bus socket
134 | prop_Bus :: Property
135 | prop_Bus = monadicIO $ do
136 |     (msgs :: [ByteString]) <- pick arbitrary
137 |     pre $ not (null msgs)
138 |     res <- run $ do
139 |         -- Probably not how you're supposed to connect Bus nodes..
140 |         b1 <- socket Bus
141 |         _ <- bind b1 "inproc://bus1"
142 |         b2 <- socket Bus
143 |         _ <- connect b2 "inproc://bus1"
144 |         _ <- bind b2 "inproc://bus2"
145 |         b3 <- socket Bus
146 |         _ <- connect b3 "inproc://bus2"
147 |         _ <- bind b3 "inproc://bus3"
148 |         _ <- connect b1 "inproc://bus3"
149 |         threadDelay 1000
150 |         r <- mapM (testSockets b1 b2 b3) msgs
151 |         close b1
152 |         close b2
153 |         close b3
154 |         threadDelay 1000
155 |         return r
156 |     assert $ and res
157 |         where
158 |             testSockets b1 b2 b3 msg = do
159 |                 send b1 msg
160 |                 a <- recv b2
161 |                 b <- recv b3
162 |                 send b2 msg
163 |                 c <- recv b1
164 |                 d <- recv b3
165 |                 send b3 msg
166 |                 e <- recv b1
167 |                 f <- recv b2
168 |                 return $ all (== msg) [a, b, c, d, e, f]
169 | 
170 | -- options
171 | test_options :: TestTree
172 | test_options = sequentialTestGroup "options" AllFinish
173 |     [ roundtrip "tcpNoDelay" Req tcpNoDelay setTcpNoDelay 0
174 |     , roundtrip "requestResendInterval" Req requestResendInterval setRequestResendInterval 30000
175 |     , roundtrip "ipv4Only0" Req ipv4Only setIpv4Only 0
176 |     , roundtrip "ipv4Only1" Req ipv4Only setIpv4Only 1
177 |     , roundtrip "sndPrio" Req sndPrio setSndPrio 7
178 |     , roundtrip "reconnectInterval" Req reconnectInterval setReconnectInterval 50
179 |     , roundtrip "reconnectIntervalMax" Req reconnectIntervalMax setReconnectIntervalMax 400
180 |     , roundtrip "rcvBuf" Req rcvBuf setRcvBuf 200000
181 |     , roundtrip "sndBuf" Req sndBuf setSndBuf 150000
182 |     , roundtrip "surveyorDeadline" Surveyor surveyorDeadline setSurveyorDeadline 2000
183 |     ]
184 |   where
185 |     roundtrip :: (Eq v, Show v, SocketType a)
186 |               => String
187 |               -> a
188 |               -> (Socket a -> IO v)
189 |               -> (Socket a -> v -> IO ())
190 |               -> v
191 |               -> TestTree
192 |     roundtrip name sockTy get set value = testProperty name $ monadicIO $ run $ do
193 |         sock <- socket sockTy
194 |         _ <- bind sock "tcp://*:5560"
195 |         threadDelay 1000
196 |         set sock value
197 |         v <- get sock
198 |         close sock
199 |         return $ value === v
200 | 
201 | tests :: TestTree
202 | tests = sequentialTestGroup "Properties" AllFinish
203 |     [ testProperty "reverse" prop_reverse
204 |     , testProperty "PubSub" prop_PubSub
205 |     , testProperty "Pair" prop_Pair
206 |     , testProperty "Pipeline" prop_Pipeline
207 |     , testProperty "ReqRep" prop_ReqRep
208 |     , testProperty "Bus" prop_Bus
209 |     ]
210 | 
211 | 


--------------------------------------------------------------------------------
/tests/BinaryProperties.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TemplateHaskell #-}
  2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  3 | module BinaryProperties where
  4 | 
  5 | import Nanomsg.Binary
  6 | import Test.QuickCheck
  7 | import Test.QuickCheck.Monadic
  8 | import Test.Tasty (TestTree, sequentialTestGroup, DependencyType(AllFinish))
  9 | import Test.Tasty.QuickCheck (testProperty)
 10 | import Data.ByteString (ByteString)
 11 | import qualified Data.ByteString.Char8 as C
 12 | import Control.Concurrent (threadDelay)
 13 | import Control.Applicative ( (<$>) )
 14 | import Data.Maybe (catMaybes)
 15 | 
 16 | instance Arbitrary ByteString where
 17 |     arbitrary = C.pack <$> arbitrary
 18 | 
 19 | -- dummy test
 20 | prop_reverse :: [Int] -> Bool
 21 | prop_reverse xs =
 22 |     xs == reverse (reverse xs)
 23 | 
 24 | type MsgType = PropertyM IO [String]
 25 | 
 26 | -- test Pub and Sub sockets
 27 | prop_PubSub :: Property
 28 | prop_PubSub = monadicIO $ do
 29 |     msgs <- pick arbitrary :: MsgType
 30 |     pre $ not (null msgs)
 31 |     res <- run $ do
 32 |         pub <- socket Pub
 33 |         ep1 <- bind pub "inproc://pubsub"
 34 |         sub1 <- socket Sub
 35 |         ep2 <- connect sub1 "inproc://pubsub"
 36 |         subscribe sub1 $ C.pack ""
 37 |         sub2 <- socket Sub
 38 |         ep3 <- connect sub2 "inproc://pubsub"
 39 |         subscribe sub2 $ C.pack ""
 40 |         threadDelay 1000
 41 |         r <- mapM (sendMsg pub sub1 sub2) msgs
 42 |         unsubscribe sub2 $ C.pack ""
 43 |         unsubscribe sub1 $ C.pack ""
 44 |         shutdown sub2 ep3
 45 |         shutdown sub1 ep2
 46 |         shutdown pub ep1
 47 |         close pub
 48 |         close sub1
 49 |         close sub2
 50 |         threadDelay 1000
 51 |         return r
 52 |     assert $ and res
 53 |         where
 54 |             sendMsg pub sub1 sub2 msg = do
 55 |                 send pub msg
 56 |                 send pub msg
 57 |                 a <- recv sub1
 58 |                 b <- recv sub1
 59 |                 c <- recv sub2
 60 |                 d <- recv sub2
 61 |                 return $ a == msg && b == msg && c == msg && d == msg
 62 | 
 63 | -- test Pair sockets
 64 | prop_Pair :: Property
 65 | prop_Pair = monadicIO $ do
 66 |     msgs <- pick arbitrary :: MsgType
 67 |     let recvS :: (Receiver a) => Socket a -> IO String
 68 |         recvS = recv
 69 |     pre $ not (null msgs)
 70 |     res <- run $ do
 71 |         s1 <- socket Pair
 72 |         _ <- bind s1 "inproc://pair"
 73 |         s2 <- socket Pair
 74 |         _ <- connect s2 "inproc://pair"
 75 |         threadDelay 1000
 76 |         -- Send message from s1 to s2, then back from s2 to s1, then make sure it hasn't changed
 77 |         r <- mapM (\m -> send s1 m >> recvS s2 >>= send s2 >> recv s1 >>= return . (== m)) msgs
 78 |         close s1
 79 |         close s2
 80 |         threadDelay 1000
 81 |         return r
 82 |     assert $ and res
 83 | 
 84 | -- test Pipeline (Push & Pull) sockets
 85 | prop_Pipeline :: Property
 86 | prop_Pipeline = monadicIO $ do
 87 |     msgs <- pick arbitrary :: MsgType
 88 |     pre $ not (null msgs)
 89 |     res <- run $ do
 90 |         push <- socket Push
 91 |         _ <- bind push "inproc://pipeline"
 92 |         pull1 <- socket Pull
 93 |         pull2 <- socket Pull
 94 |         _ <- connect pull1 "inproc://pipeline"
 95 |         _ <- connect pull2 "inproc://pipeline"
 96 |         threadDelay 1000
 97 |         r <- mapM (testSockets push pull1 pull2) msgs
 98 |         close push
 99 |         close pull1
100 |         close pull2
101 |         threadDelay 1000
102 |         return r
103 |     assert $ and res
104 |         where
105 |             testSockets push pull1 pull2 msg = do
106 |                 send push msg
107 |                 send push msg
108 |                 send push msg
109 |                 threadDelay 1000
110 |                 a <- recv' pull1
111 |                 b <- recv' pull1
112 |                 c <- recv' pull1
113 |                 d <- recv' pull2
114 |                 e <- recv' pull2
115 |                 f <- recv' pull2
116 |                 let xs = catMaybes [a, b, c, d, e, f]
117 |                 return $ all (== msg) xs && (length xs == 3)
118 | 
119 | -- test Req and Rep sockets
120 | prop_ReqRep :: Property
121 | prop_ReqRep = monadicIO $ do
122 |     msgs <- pick arbitrary :: MsgType
123 |     let recvS :: (Receiver a) => Socket a -> IO String
124 |         recvS = recv
125 |     pre $ not (null msgs)
126 |     res <- run $ do
127 |         req <- socket Req
128 |         _ <- bind req "inproc://reqrep"
129 |         rep <- socket Rep
130 |         _ <- connect rep "inproc://reqrep"
131 |         threadDelay 1000
132 |         r <- mapM (\m -> send req m >> recvS rep >>= send rep >> recv req >>= return . (== m)) msgs
133 |         close req
134 |         close rep
135 |         threadDelay 1000
136 |         return r
137 |     assert $ and res
138 | 
139 | -- test Bus socket
140 | prop_Bus :: Property
141 | prop_Bus = monadicIO $ do
142 |     msgs <- pick arbitrary :: MsgType
143 |     pre $ not (null msgs)
144 |     res <- run $ do
145 |         -- Probably not how you're supposed to connect Bus nodes..
146 |         b1 <- socket Bus
147 |         _ <- bind b1 "inproc://bus1"
148 |         b2 <- socket Bus
149 |         _ <- connect b2 "inproc://bus1"
150 |         _ <- bind b2 "inproc://bus2"
151 |         b3 <- socket Bus
152 |         _ <- connect b3 "inproc://bus2"
153 |         _ <- bind b3 "inproc://bus3"
154 |         _ <- connect b1 "inproc://bus3"
155 |         threadDelay 1000
156 |         r <- mapM (testSockets b1 b2 b3) msgs
157 |         close b1
158 |         close b2
159 |         close b3
160 |         threadDelay 1000
161 |         return r
162 |     assert $ and res
163 |         where
164 |             testSockets b1 b2 b3 msg = do
165 |                 send b1 msg
166 |                 a <- recv b2
167 |                 b <- recv b3
168 |                 send b2 msg
169 |                 c <- recv b1
170 |                 d <- recv b3
171 |                 send b3 msg
172 |                 e <- recv b1
173 |                 f <- recv b2
174 |                 return $ all (== msg) [a, b, c, d, e, f]
175 | 
176 | -- options
177 | test_options :: TestTree
178 | test_options = sequentialTestGroup "options" AllFinish
179 |     [ roundtrip "tcpNoDelay" Req tcpNoDelay setTcpNoDelay 0
180 |     , roundtrip "requestResendInterval" Req requestResendInterval setRequestResendInterval 30000
181 |     , roundtrip "ipv4Only0" Req ipv4Only setIpv4Only 0
182 |     , roundtrip "ipv4Only1" Req ipv4Only setIpv4Only 1
183 |     , roundtrip "sndPrio" Req sndPrio setSndPrio 7
184 |     , roundtrip "reconnectInterval" Req reconnectInterval setReconnectInterval 50
185 |     , roundtrip "reconnectIntervalMax" Req reconnectIntervalMax setReconnectIntervalMax 400
186 |     , roundtrip "rcvBuf" Req rcvBuf setRcvBuf 200000
187 |     , roundtrip "sndBuf" Req sndBuf setSndBuf 150000
188 |     , roundtrip "surveyorDeadline" Surveyor surveyorDeadline setSurveyorDeadline 2000
189 |     ]
190 |   where
191 |     roundtrip :: (Eq v, Show v, SocketType a)
192 |               => String
193 |               -> a
194 |               -> (Socket a -> IO v)
195 |               -> (Socket a -> v -> IO ())
196 |               -> v
197 |               -> TestTree
198 |     roundtrip name sockTy get set value = testProperty name $ monadicIO $ run $ do
199 |         sock <- socket sockTy
200 |         _ <- bind sock "tcp://*:5561"
201 |         threadDelay 1000
202 |         set sock value
203 |         v <- get sock
204 |         close sock
205 |         return $ value === v
206 | 
207 | tests :: TestTree
208 | tests = sequentialTestGroup "BinaryProperties" AllFinish
209 |     [ testProperty "reverse" prop_reverse
210 |     , testProperty "PubSub" prop_PubSub
211 |     , testProperty "Pair" prop_Pair
212 |     , testProperty "Pipeline" prop_Pipeline
213 |     , testProperty "ReqRep" prop_ReqRep
214 |     , testProperty "Bus" prop_Bus
215 |     ]
216 | 
217 | 


--------------------------------------------------------------------------------
/.github/workflows/haskell-ci.yml:
--------------------------------------------------------------------------------
  1 | # This GitHub workflow config has been generated by a script via
  2 | #
  3 | #   haskell-ci '--apt' 'libnanomsg5' '--apt' 'libnanomsg-dev' '--apt' 'libczmq-dev' 'github' './nanomsg-haskell.cabal'
  4 | #
  5 | # To regenerate the script (for example after adjusting tested-with) run
  6 | #
  7 | #   haskell-ci regenerate
  8 | #
  9 | # For more information, see https://github.com/haskell-CI/haskell-ci
 10 | #
 11 | # version: 0.19.20250330
 12 | #
 13 | # REGENDATA ("0.19.20250330",["--apt","libnanomsg5","--apt","libnanomsg-dev","--apt","libczmq-dev","github","./nanomsg-haskell.cabal"])
 14 | #
 15 | name: Haskell-CI
 16 | on:
 17 |   - push
 18 |   - pull_request
 19 | jobs:
 20 |   linux:
 21 |     name: Haskell-CI - Linux - ${{ matrix.compiler }}
 22 |     runs-on: ubuntu-24.04
 23 |     timeout-minutes:
 24 |       60
 25 |     container:
 26 |       image: buildpack-deps:jammy
 27 |     continue-on-error: ${{ matrix.allow-failure }}
 28 |     strategy:
 29 |       matrix:
 30 |         include:
 31 |           - compiler: ghc-9.12.2
 32 |             compilerKind: ghc
 33 |             compilerVersion: 9.12.2
 34 |             setup-method: ghcup
 35 |             allow-failure: false
 36 |           - compiler: ghc-9.10.1
 37 |             compilerKind: ghc
 38 |             compilerVersion: 9.10.1
 39 |             setup-method: ghcup
 40 |             allow-failure: false
 41 |           - compiler: ghc-9.8.2
 42 |             compilerKind: ghc
 43 |             compilerVersion: 9.8.2
 44 |             setup-method: ghcup
 45 |             allow-failure: false
 46 |           - compiler: ghc-9.6.5
 47 |             compilerKind: ghc
 48 |             compilerVersion: 9.6.5
 49 |             setup-method: ghcup
 50 |             allow-failure: false
 51 |           - compiler: ghc-9.4.7
 52 |             compilerKind: ghc
 53 |             compilerVersion: 9.4.7
 54 |             setup-method: ghcup
 55 |             allow-failure: false
 56 |       fail-fast: false
 57 |     steps:
 58 |       - name: apt-get install
 59 |         run: |
 60 |           apt-get update
 61 |           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
 62 |           apt-get install -y libczmq-dev libnanomsg-dev libnanomsg5
 63 |       - name: Install GHCup
 64 |         run: |
 65 |           mkdir -p "$HOME/.ghcup/bin"
 66 |           curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup"
 67 |           chmod a+x "$HOME/.ghcup/bin/ghcup"
 68 |       - name: Install cabal-install
 69 |         run: |
 70 |           "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false)
 71 |           echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV"
 72 |       - name: Install GHC (GHCup)
 73 |         if: matrix.setup-method == 'ghcup'
 74 |         run: |
 75 |           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
 76 |           HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
 77 |           HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
 78 |           HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
 79 |           echo "HC=$HC" >> "$GITHUB_ENV"
 80 |           echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
 81 |           echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
 82 |         env:
 83 |           HCKIND: ${{ matrix.compilerKind }}
 84 |           HCNAME: ${{ matrix.compiler }}
 85 |           HCVER: ${{ matrix.compilerVersion }}
 86 |       - name: Set PATH and environment variables
 87 |         run: |
 88 |           echo "$HOME/.cabal/bin" >> $GITHUB_PATH
 89 |           echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
 90 |           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
 91 |           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
 92 |           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
 93 |           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
 94 |           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
 95 |           echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
 96 |           echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
 97 |           echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
 98 |         env:
 99 |           HCKIND: ${{ matrix.compilerKind }}
100 |           HCNAME: ${{ matrix.compiler }}
101 |           HCVER: ${{ matrix.compilerVersion }}
102 |       - name: env
103 |         run: |
104 |           env
105 |       - name: write cabal config
106 |         run: |
107 |           mkdir -p $CABAL_DIR
108 |           cat >> $CABAL_CONFIG <<EOF
109 |           remote-build-reporting: anonymous
110 |           write-ghc-environment-files: never
111 |           remote-repo-cache: $CABAL_DIR/packages
112 |           logs-dir:          $CABAL_DIR/logs
113 |           world-file:        $CABAL_DIR/world
114 |           extra-prog-path:   $CABAL_DIR/bin
115 |           symlink-bindir:    $CABAL_DIR/bin
116 |           installdir:        $CABAL_DIR/bin
117 |           build-summary:     $CABAL_DIR/logs/build.log
118 |           store-dir:         $CABAL_DIR/store
119 |           install-dirs user
120 |             prefix: $CABAL_DIR
121 |           repository hackage.haskell.org
122 |             url: http://hackage.haskell.org/
123 |           EOF
124 |           cat >> $CABAL_CONFIG <<EOF
125 |           program-default-options
126 |             ghc-options: $GHCJOBS +RTS -M3G -RTS
127 |           EOF
128 |           cat $CABAL_CONFIG
129 |       - name: versions
130 |         run: |
131 |           $HC --version || true
132 |           $HC --print-project-git-commit-id || true
133 |           $CABAL --version || true
134 |       - name: update cabal index
135 |         run: |
136 |           $CABAL v2-update -v
137 |       - name: install cabal-plan
138 |         run: |
139 |           mkdir -p $HOME/.cabal/bin
140 |           curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
141 |           echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2  cabal-plan.xz' | sha256sum -c -
142 |           xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
143 |           rm -f cabal-plan.xz
144 |           chmod a+x $HOME/.cabal/bin/cabal-plan
145 |           cabal-plan --version
146 |       - name: checkout
147 |         uses: actions/checkout@v4
148 |         with:
149 |           path: source
150 |       - name: initial cabal.project for sdist
151 |         run: |
152 |           touch cabal.project
153 |           echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
154 |           cat cabal.project
155 |       - name: sdist
156 |         run: |
157 |           mkdir -p sdist
158 |           $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
159 |       - name: unpack
160 |         run: |
161 |           mkdir -p unpacked
162 |           find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
163 |       - name: generate cabal.project
164 |         run: |
165 |           PKGDIR_nanomsg_haskell="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/nanomsg-haskell-[0-9.]*')"
166 |           echo "PKGDIR_nanomsg_haskell=${PKGDIR_nanomsg_haskell}" >> "$GITHUB_ENV"
167 |           rm -f cabal.project cabal.project.local
168 |           touch cabal.project
169 |           touch cabal.project.local
170 |           echo "packages: ${PKGDIR_nanomsg_haskell}" >> cabal.project
171 |           echo "package nanomsg-haskell" >> cabal.project
172 |           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
173 |           cat >> cabal.project <<EOF
174 |           EOF
175 |           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(nanomsg-haskell)$/; }' >> cabal.project.local
176 |           cat cabal.project
177 |           cat cabal.project.local
178 |       - name: dump install plan
179 |         run: |
180 |           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
181 |           cabal-plan
182 |       - name: restore cache
183 |         uses: actions/cache/restore@v4
184 |         with:
185 |           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
186 |           path: ~/.cabal/store
187 |           restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
188 |       - name: install dependencies
189 |         run: |
190 |           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
191 |           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
192 |       - name: build w/o tests
193 |         run: |
194 |           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
195 |       - name: build
196 |         run: |
197 |           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
198 |       - name: tests
199 |         run: |
200 |           $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
201 |       - name: cabal check
202 |         run: |
203 |           cd ${PKGDIR_nanomsg_haskell} || false
204 |           ${CABAL} -vnormal check
205 |       - name: haddock
206 |         run: |
207 |           $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
208 |       - name: unconstrained build
209 |         run: |
210 |           rm -f cabal.project.local
211 |           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
212 |       - name: save cache
213 |         if: always()
214 |         uses: actions/cache/save@v4
215 |         with:
216 |           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
217 |           path: ~/.cabal/store
218 | 


--------------------------------------------------------------------------------
/src/Nanomsg.hsc:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
  2 | -- |
  3 | -- Module:          Nanomsg
  4 | -- Copyright:       (c) 2013 Ivar Nymoen
  5 | -- License:         MIT
  6 | -- Stability:       experimental
  7 | --
  8 | -- This is a Haskell binding for the nanomsg library: <http://nanomsg.org/>.
  9 | --
 10 | -- There's support for (evented) blocking send and recv, a non-blocking receive,
 11 | -- and for all the socket types and the functions you need to wire
 12 | -- them up and tear them down again.
 13 | --
 14 | -- Most socket options are available through accessor and mutator
 15 | -- functions. Sockets are typed, transports are not.
 16 | --
 17 | -- The documentation is adapted or quoted verbatim from the nanomsg manual,
 18 | -- please refer to nanomsg.org for authoritative info.
 19 | -- There's a simple code example in <https://github.com/ivarnymoen/nanomsg-haskell#usage README.md>.
 20 | module Nanomsg
 21 |         (
 22 |         -- * Types
 23 |         -- ** Socket types
 24 |           Pair(..)
 25 |         , Req(..)
 26 |         , Rep(..)
 27 |         , Pub(..)
 28 |         , Sub(..)
 29 |         , Surveyor(..)
 30 |         , Respondent(..)
 31 |         , Push(..)
 32 |         , Pull(..)
 33 |         , Bus(..)
 34 |         -- ** Other
 35 |         , Socket
 36 |         , Endpoint
 37 |         , NNException
 38 |         , SocketType
 39 |         , Sender
 40 |         , Receiver
 41 |         -- * Operations
 42 |         -- ** General operations
 43 |         , socket
 44 |         , withSocket
 45 |         , bind
 46 |         , connect
 47 |         , send
 48 |         , recv
 49 |         , recv'
 50 |         , subscribe
 51 |         , unsubscribe
 52 |         , shutdown
 53 |         , close
 54 |         , term
 55 |         -- ** Socket option settings
 56 |         , linger
 57 |         , setLinger
 58 |         , sndBuf
 59 |         , setSndBuf
 60 |         , rcvBuf
 61 |         , setRcvBuf
 62 |         , rcvMaxSize
 63 |         , setRcvMaxSize
 64 |         , reconnectInterval
 65 |         , setReconnectInterval
 66 |         , reconnectIntervalMax
 67 |         , setReconnectIntervalMax
 68 |         , sndPrio
 69 |         , setSndPrio
 70 |         , ipv4Only
 71 |         , setIpv4Only
 72 |         , requestResendInterval
 73 |         , setRequestResendInterval
 74 |         , surveyorDeadline
 75 |         , setSurveyorDeadline
 76 |         , tcpNoDelay
 77 |         , setTcpNoDelay
 78 |     ) where
 79 | 
 80 | #include "nanomsg/nn.h"
 81 | #include "nanomsg/pair.h"
 82 | #include "nanomsg/reqrep.h"
 83 | #include "nanomsg/pubsub.h"
 84 | #include "nanomsg/survey.h"
 85 | #include "nanomsg/pipeline.h"
 86 | #include "nanomsg/bus.h"
 87 | #include "nanomsg/tcp.h"
 88 | 
 89 | import Data.ByteString (ByteString)
 90 | -- import qualified Data.ByteString.Lazy as L
 91 | import qualified Data.ByteString.Char8 as C
 92 | import qualified Data.ByteString.Unsafe as U
 93 | import Foreign (peek, poke, alloca)
 94 | import Foreign.Ptr
 95 | import Foreign.C.Types
 96 | import Foreign.C.String
 97 | import Foreign.Storable (sizeOf)
 98 | import Control.Applicative ( (<$>) )
 99 | import Control.Exception.Base (bracket)
100 | import Control.Exception (Exception, throwIO)
101 | import Data.Typeable (Typeable)
102 | import Control.Monad (void)
103 | import Text.Printf (printf)
104 | import Control.Concurrent (threadWaitRead, threadWaitWrite)
105 | import System.Posix.Types (Fd(..))
106 | 
107 | 
108 | -- * Data and typedefs
109 | 
110 | -- | Socket for communication with exactly one peer. Each
111 | -- party can send messages at any time. If the peer is not
112 | -- available or the send buffer is full, subsequent calls
113 | -- will block until it’s possible to send the message.
114 | data Pair = Pair
115 | 
116 | -- | Request socket. Pairs with 'Rep' sockets.
117 | --
118 | -- The socket will resend requests automatically
119 | -- if there's no reply within a given time. The default timeout
120 | -- is 1 minute.
121 | --
122 | -- See also 'Rep', 'setRequestResendInterval'.
123 | data Req = Req
124 | 
125 | -- | Reply socket.
126 | --
127 | -- See also 'Req'.
128 | data Rep = Rep
129 | 
130 | -- | Publish socket. Pairs with subscribe sockets.
131 | --
132 | -- See also 'Sub'.
133 | data Pub = Pub
134 | 
135 | -- | Subscribe socket.
136 | --
137 | -- Only messages that the socket is subscribed to are received. When the socket
138 | -- is created there are no subscriptions and thus no messages will be received.
139 | --
140 | -- See also 'Pub', 'subscribe' and 'unsubscribe'.
141 | data Sub = Sub
142 | 
143 | -- | Surveyor and respondent are used to broadcast a survey to multiple
144 | -- locations and gather the responses.
145 | --
146 | -- This socket is used to send a survey. The survey is delivered to all
147 | -- onnected respondents. Once the query is sent, the socket can be used
148 | -- to receive the responses.
149 | --
150 | -- When the survey deadline expires, receive will throw an NNException.
151 | --
152 | -- See also 'Respondent', 'setSurveyorDeadline'.
153 | data Surveyor = Surveyor
154 | 
155 | -- | Used to respond to a survey. Survey is received using receive,
156 | -- response is sent using send. This socket can be connected to
157 | -- at most one peer.
158 | --
159 | -- See also 'Surveyor'.
160 | data Respondent = Respondent
161 | 
162 | -- | Push and Pull sockets fair queue messages from one processing step, load
163 | -- balancing them among instances of the next processing step.
164 | --
165 | -- See also 'Pull'.
166 | data Push = Push
167 | 
168 | -- | Pull socket.
169 | --
170 | -- See also 'Push'.
171 | data Pull = Pull
172 | 
173 | -- | Broadcasts messages from any node to all other nodes in the topology.
174 | -- The socket should never receives messages that it sent itself.
175 | data Bus = Bus
176 | 
177 | -- | Endpoint identifier. Created by 'connect' or 'bind'.
178 | --
179 | -- Close connections using 'shutdown'.
180 | data Endpoint = Endpoint CInt
181 |     deriving (Eq, Show)
182 | 
183 | -- | Sockets are created by 'socket' and connections are established with 'connect' or 'bind'.
184 | --
185 | -- Free sockets using 'close'.
186 | data Socket a = Socket a CInt
187 |     deriving (Eq, Show)
188 | 
189 | -- | Typeclass for all sockets
190 | class SocketType a where
191 |     socketType :: a -> CInt -- ^ Returns the C enum value for each type. E.g. Pair => #const NN_PAIR
192 | 
193 | instance SocketType Pair where
194 |     socketType Pair = #const NN_PAIR
195 | 
196 | instance SocketType Req where
197 |     socketType Req = #const NN_REQ
198 | 
199 | instance SocketType Rep where
200 |     socketType Rep = #const NN_REP
201 | 
202 | instance SocketType Pub where
203 |     socketType Pub = #const NN_PUB
204 | 
205 | instance SocketType Sub where
206 |     socketType Sub = #const NN_SUB
207 | 
208 | instance SocketType Surveyor where
209 |     socketType Surveyor = #const NN_SURVEYOR
210 | 
211 | instance SocketType Respondent where
212 |     socketType Respondent = #const NN_RESPONDENT
213 | 
214 | instance SocketType Push where
215 |     socketType Push = #const NN_PUSH
216 | 
217 | instance SocketType Pull where
218 |     socketType Pull = #const NN_PULL
219 | 
220 | instance SocketType Bus where
221 |     socketType Bus = #const NN_BUS
222 | 
223 | 
224 | -- | Typeclass restricting which sockets can use the send function.
225 | class (SocketType a) => Sender a
226 | instance Sender Pair
227 | instance Sender Req
228 | instance Sender Rep
229 | instance Sender Pub
230 | instance Sender Surveyor
231 | instance Sender Respondent
232 | instance Sender Push
233 | instance Sender Bus
234 | 
235 | -- | Typeclass for sockets that implement recv
236 | class (SocketType a) => Receiver a
237 | instance Receiver Pair
238 | instance Receiver Req
239 | instance Receiver Rep
240 | instance Receiver Sub
241 | instance Receiver Surveyor
242 | instance Receiver Respondent
243 | instance Receiver Pull
244 | instance Receiver Bus
245 | 
246 | 
247 | -- * Error handling
248 | --
249 | -- Reimplementing some of Foreign.C.Error here, to substitute nanomsg's errno
250 | -- and strerror functions for the posix ones.
251 | 
252 | -- | Pretty much any error condition throws this exception.
253 | data NNException = NNException String
254 |         deriving (Eq, Show, Typeable)
255 | 
256 | instance Exception NNException
257 | 
258 | mkErrorString :: String -> IO String
259 | mkErrorString loc = do
260 |     errNo <- c_nn_errno
261 |     errCString <- c_nn_strerror errNo
262 |     errString <- peekCString errCString
263 |     return $ printf "nanomsg-haskell error at %s. Errno %d: %s" loc (fromIntegral errNo :: Int) errString
264 | 
265 | throwErrno :: String -> IO a
266 | throwErrno loc = do
267 |     s <- mkErrorString loc
268 |     throwIO $ NNException s
269 | 
270 | throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a
271 | throwErrnoIf p loc action = do
272 |     res <- action
273 |     if p res then throwErrno loc else return res
274 | 
275 | throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO ()
276 | throwErrnoIf_ p loc action = void $ throwErrnoIf p loc action
277 | 
278 | throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a
279 | throwErrnoIfMinus1 = throwErrnoIf (== -1)
280 | 
281 | throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO ()
282 | throwErrnoIfMinus1_ = throwErrnoIf_ (== -1)
283 | 
284 | throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a
285 | throwErrnoIfRetry p loc f = do
286 |     res <- f
287 |     if p res
288 |         then do
289 |             err <- c_nn_errno
290 |             if err == (#const EAGAIN) || err == (#const EINTR)
291 |                 then throwErrnoIfRetry p loc f
292 |                 else throwErrno loc
293 |         else return res
294 | 
295 | throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
296 | throwErrnoIfRetry_ p loc f = void $ throwErrnoIfRetry p loc f
297 | 
298 | {-
299 | throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a
300 | throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1)
301 | -}
302 | 
303 | throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO ()
304 | throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
305 | 
306 | throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a
307 | throwErrnoIfRetryMayBlock p loc f on_block = do
308 |     res <- f
309 |     if p res
310 |         then do
311 |             err <- c_nn_errno
312 |             if err `elem` [ (#const EAGAIN), (#const EINTR), (#const EWOULDBLOCK) ]
313 |                 then do
314 |                     void on_block
315 |                     throwErrnoIfRetryMayBlock p loc f on_block
316 |                 else throwErrno loc
317 |         else return res
318 | 
319 | throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
320 | throwErrnoIfRetryMayBlock_ p loc f on_block = void $ throwErrnoIfRetryMayBlock p loc f on_block
321 | 
322 | throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a) => String -> IO a -> IO b -> IO a
323 | throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
324 | 
325 | throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a) => String -> IO a -> IO b -> IO ()
326 | throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1)
327 | 
328 | 
329 | -- * FFI functions
330 | 
331 | -- NN_EXPORT int nn_socket (int domain, int protocol);
332 | foreign import ccall safe "nn.h nn_socket"
333 |     c_nn_socket :: CInt -> CInt -> IO CInt
334 | 
335 | -- NN_EXPORT int nn_bind (int s, const char *addr);
336 | foreign import ccall safe "nn.h nn_bind"
337 |     c_nn_bind :: CInt -> CString -> IO CInt
338 | 
339 | -- NN_EXPORT int nn_connect (int s, const char *addr);
340 | foreign import ccall safe "nn.h nn_connect"
341 |     c_nn_connect :: CInt -> CString -> IO CInt
342 | 
343 | -- NN_EXPORT int nn_shutdown (int s, int how);
344 | foreign import ccall safe "nn.h nn_shutdown"
345 |     c_nn_shutdown :: CInt -> CInt -> IO CInt
346 | 
347 | -- NN_EXPORT int nn_send (int s, const void *buf, size_t len, int flags);
348 | foreign import ccall safe "nn.h nn_send"
349 |     c_nn_send :: CInt -> CString -> CSize -> CInt -> IO CInt
350 | 
351 | -- NN_EXPORT int nn_recv (int s, void *buf, size_t len, int flags);
352 | foreign import ccall safe "nn.h nn_recv"
353 |     c_nn_recv :: CInt -> Ptr CString -> CSize -> CInt -> IO CInt
354 | 
355 | -- NN_EXPORT int nn_freemsg (void *msg);
356 | foreign import ccall safe "nn.h nn_freemsg"
357 |     c_nn_freemsg :: Ptr CChar -> IO CInt
358 | 
359 | -- NN_EXPORT int nn_close (int s);
360 | foreign import ccall safe "nn.h nn_close"
361 |     c_nn_close :: CInt -> IO CInt
362 | 
363 | -- NN_EXPORT void nn_term (void);
364 | foreign import ccall safe "nn.h nn_term"
365 |     c_nn_term :: IO ()
366 | 
367 | -- NN_EXPORT int nn_setsockopt (int s, int level, int option, const void *optval, size_t optvallen);
368 | foreign import ccall safe "nn.h nn_setsockopt"
369 |     c_nn_setsockopt :: CInt -> CInt -> CInt -> Ptr a -> CSize -> IO CInt
370 | 
371 | -- NN_EXPORT int nn_getsockopt (int s, int level, int option, void *optval, size_t *optvallen);
372 | foreign import ccall safe "nn.h nn_getsockopt"
373 |     c_nn_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CSize -> IO CInt
374 | 
375 | -- /*  Resolves system errors and native errors to human-readable string.        */
376 | -- NN_EXPORT const char *nn_strerror (int errnum);
377 | foreign import ccall safe "nn.h nn_strerror"
378 |     c_nn_strerror :: CInt -> IO CString
379 | 
380 | -- /*  This function retrieves the errno as it is known to the library.          */
381 | -- /*  The goal of this function is to make the code 100% portable, including    */
382 | -- /*  where the library is compiled with certain CRT library (on Windows) and   */
383 | -- /*  linked to an application that uses different CRT library.                 */
384 | -- NN_EXPORT int nn_errno (void);
385 | foreign import ccall safe "nn.h nn_errno"
386 |     c_nn_errno :: IO CInt
387 | 
388 | {-
389 | 
390 | Unbound FFI functions:
391 | 
392 | NN_EXPORT int nn_sendmsg (int s, const struct nn_msghdr *msghdr, int flags);
393 | NN_EXPORT int nn_recvmsg (int s, struct nn_msghdr *msghdr, int flags);
394 | 
395 | NN_EXPORT void *nn_allocmsg (size_t size, int type);
396 | -}
397 | 
398 | -- * Operations
399 | 
400 | -- | Creates a socket. Connections are formed using 'bind' or 'connect'.
401 | --
402 | -- See also: 'close'.
403 | socket :: (SocketType a) => a -> IO (Socket a)
404 | socket t = do
405 |     sid <- throwErrnoIfMinus1 "socket" $ c_nn_socket (#const AF_SP) (socketType t)
406 |     return $ Socket t sid
407 | 
408 | -- | Creates a socket and runs your action with it.
409 | --
410 | -- E.g. collecting 10 messages:
411 | --
412 | -- > withSocket Sub $ \sub -> do
413 | -- >     _ <- connect sub "tcp://localhost:5560"
414 | -- >     subscribe sub (C.pack "")
415 | -- >     replicateM 10 (recv sub)
416 | --
417 | -- Ensures the socket is closed when your action is done.
418 | withSocket :: (SocketType a) => a -> (Socket a -> IO b) -> IO b
419 | withSocket t = bracket (socket t) close
420 | 
421 | -- | Binds the socket to a local interface.
422 | --
423 | -- See the nanomsg documentation for specifics on transports.
424 | -- Note that host names do not work for tcp. Some examples are:
425 | --
426 | -- > bind sock "tcp://*:5560"
427 | -- > bind sock "tcp://eth0:5560"
428 | -- > bind sock "tcp://127.0.0.1:5560"
429 | -- > bind sock "inproc://test"
430 | -- > bind sock "ipc:///tmp/test.ipc"
431 | --
432 | -- This function returns an 'Endpoint', which can be supplied
433 | -- to 'shutdown' to remove a connection.
434 | --
435 | -- See also: 'connect', 'shutdown'.
436 | bind :: Socket a -> String -> IO Endpoint
437 | bind (Socket _ sid) addr =
438 |     withCString addr $ \adr -> do
439 |         epid <- throwErrnoIfMinus1 "bind" $ c_nn_bind sid adr
440 |         return $ Endpoint epid
441 | 
442 | -- | Connects the socket to an endpoint.
443 | --
444 | -- e.g. :
445 | --
446 | -- > connect sock "tcp://localhost:5560"
447 | -- > connect sock "inproc://test"
448 | --
449 | -- See also: 'bind', 'shutdown'.
450 | connect :: Socket a -> String -> IO Endpoint
451 | connect (Socket _ sid) addr =
452 |     withCString addr $ \adr -> do
453 |         epid <- throwErrnoIfMinus1 "connect" $ c_nn_connect sid adr
454 |         return $ Endpoint epid
455 | 
456 | -- | Removes an endpoint from a socket.
457 | --
458 | -- See also: 'bind', 'connect'.
459 | shutdown :: Socket a -> Endpoint -> IO ()
460 | shutdown (Socket _ sid) (Endpoint eid) =
461 |     throwErrnoIfMinus1_ "shutdown" $ c_nn_shutdown sid eid
462 | 
463 | -- | Blocking function for sending a message
464 | --
465 | -- See also: 'recv', 'recv''.
466 | send :: Sender a => Socket a -> ByteString -> IO ()
467 | send (Socket t sid) string =
468 |     U.unsafeUseAsCStringLen string $ \(ptr, len) ->
469 |         throwErrnoIfMinus1RetryMayBlock_
470 |             "send"
471 |             (c_nn_send sid ptr (fromIntegral len) (#const NN_DONTWAIT))
472 |             (getOptionFd (Socket t sid) (#const NN_SNDFD) >>= threadWaitRead)
473 | 
474 | -- | Blocking receive.
475 | recv :: Receiver a => Socket a -> IO ByteString
476 | recv (Socket t sid) =
477 |     alloca $ \ptr -> do
478 |         len <- throwErrnoIfMinus1RetryMayBlock
479 |                 "recv"
480 |                 (c_nn_recv sid ptr (#const NN_MSG) (#const NN_DONTWAIT))
481 |                 (getOptionFd (Socket t sid) (#const NN_RCVFD) >>= threadWaitRead)
482 |         buf <- peek ptr
483 |         str <- C.packCStringLen (buf, fromIntegral len)
484 |         throwErrnoIfMinus1_ "recv freeing message buffer" $ c_nn_freemsg buf
485 |         return str
486 | 
487 | -- | Nonblocking receive function.
488 | recv' :: Receiver a => Socket a -> IO (Maybe ByteString)
489 | recv' (Socket _ sid) =
490 |     alloca $ \ptr -> do
491 |         len <- c_nn_recv sid ptr (#const NN_MSG) (#const NN_DONTWAIT)
492 |         if len >= 0
493 |             then do
494 |                 buf <- peek ptr
495 |                 str <- C.packCStringLen (buf, fromIntegral len)
496 |                 throwErrnoIfMinus1_ "recv' freeing message buffer" $ c_nn_freemsg buf
497 |                 return $ Just str
498 |             else do
499 |                 errno <- c_nn_errno
500 |                 if errno == (#const EAGAIN) || errno == (#const EINTR)
501 |                     then return Nothing
502 |                     else throwErrno "recv'"
503 | 
504 | -- | Subscribe to a given subject string.
505 | subscribe :: Socket Sub -> ByteString -> IO ()
506 | subscribe (Socket t sid) string =
507 |     setOption (Socket t sid) (socketType t) (#const NN_SUB_SUBSCRIBE) (StringOption string)
508 | 
509 | -- | Unsubscribes from a subject.
510 | unsubscribe :: Socket Sub -> ByteString -> IO ()
511 | unsubscribe (Socket t sid) string =
512 |     setOption (Socket t sid) (socketType t) (#const NN_SUB_UNSUBSCRIBE) (StringOption string)
513 | 
514 | -- | Closes the socket. Any buffered inbound messages that were not yet
515 | -- received by the application will be discarded. The library will try to
516 | -- deliver any outstanding outbound messages for the time specified by
517 | -- NN_LINGER socket option. The call will block in the meantime.
518 | close :: Socket a -> IO ()
519 | close (Socket _ sid) =
520 |     throwErrnoIfMinus1Retry_ "close" $ c_nn_close sid
521 | 
522 | -- | Switches nanomsg into shutdown modus and interrupts any waiting
523 | -- function calls.
524 | term :: IO ()
525 | term = c_nn_term
526 | 
527 | 
528 | -- * Socket option accessors and mutators
529 | 
530 | -- not sure if this beats having setOptionInt and setOptionString..
531 | data SocketOption = IntOption Int | StringOption ByteString
532 |     deriving (Show)
533 | 
534 | -- Used for setting a socket option.
535 | setOption :: Socket a -> CInt -> CInt -> SocketOption -> IO ()
536 | 
537 | setOption (Socket _ sid) level option (IntOption val) =
538 |     alloca $ \ptr -> do
539 |         poke ptr (fromIntegral val :: CInt)
540 |         let cintSize = fromIntegral $ sizeOf (fromIntegral val :: CInt) :: CSize
541 |         throwErrnoIfMinus1_ "setOption (int)" $ c_nn_setsockopt sid level option ptr cintSize
542 | 
543 | setOption (Socket _ sid) level option (StringOption str) =
544 |     throwErrnoIfMinus1_ "setOption (string)" <$> U.unsafeUseAsCStringLen str $
545 |         \(ptr, len) -> c_nn_setsockopt sid level option ptr (fromIntegral len)
546 | 
547 | -- Reads a socket option.
548 | getOption :: Socket a -> CInt -> CInt -> IO CInt
549 | getOption (Socket _ sid) level option =
550 |     alloca $ \ptr ->
551 |         alloca $ \sizePtr -> do
552 |             let a = 1 :: CInt
553 |             let cintSize = fromIntegral $ sizeOf a
554 |             poke sizePtr cintSize
555 |             throwErrnoIfMinus1_ "getOption" $ c_nn_getsockopt sid level option (ptr :: Ptr CInt) sizePtr
556 |             value <- peek ptr
557 |             size <- peek sizePtr
558 |             if cintSize /= size then throwErrno "getOption: output size not as expected" else return value
559 | 
560 | -- Retrieves a nanomsg file descriptor for polling ready status.
561 | getOptionFd :: Socket a -> CInt -> IO Fd
562 | getOptionFd (Socket _ sid) option =
563 |     alloca $ \ptr ->
564 |         alloca $ \sizePtr -> do
565 |             let a = 1 :: Fd
566 |             let fdSize = fromIntegral $ sizeOf a
567 |             poke sizePtr fdSize
568 |             throwErrnoIfMinus1_ "getOptionFd" $ c_nn_getsockopt sid (#const NN_SOL_SOCKET) option (ptr :: Ptr Fd) sizePtr
569 |             value <- peek ptr
570 |             size <- peek sizePtr
571 |             if fdSize /= size then throwErrno "getOptionFd: output size not as expected" else return value
572 | 
573 | -- | Specifies how long the socket should try to send pending outbound
574 | -- messages after close has been called, in milliseconds.
575 | --
576 | -- Negative value means infinite linger. Default value is 1000 (1 second).
577 | linger :: Socket a -> IO Int
578 | linger s =
579 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_LINGER)
580 | {-# DEPRECATED linger "NN_LINGER is no longer supported by nanomsg" #-}
581 | 
582 | -- | Specifies how long should the socket try to send pending outbound
583 | -- messages after close has been called, in milliseconds.
584 | --
585 | -- Negative value means infinite linger. Default value is 1000 (1 second).
586 | setLinger :: Socket a -> Int -> IO ()
587 | setLinger s val =
588 |     setOption s (#const NN_SOL_SOCKET) (#const NN_LINGER) (IntOption val)
589 | {-# DEPRECATED setLinger "NN_LINGER is no longer supported by nanomsg" #-}
590 | 
591 | -- | Size of the send buffer, in bytes. To prevent blocking for messages
592 | -- larger than the buffer, exactly one message may be buffered in addition
593 | -- to the data in the send buffer.
594 | --
595 | -- Default value is 128kB.
596 | sndBuf :: Socket a -> IO Int
597 | sndBuf s =
598 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_SNDBUF)
599 | 
600 | -- | Size of the send buffer, in bytes. To prevent blocking for messages
601 | -- larger than the buffer, exactly one message may be buffered in addition
602 | -- to the data in the send buffer.
603 | --
604 | -- Default value is 128kB.
605 | setSndBuf :: Socket a -> Int -> IO ()
606 | setSndBuf s val =
607 |     setOption s (#const NN_SOL_SOCKET) (#const NN_SNDBUF) (IntOption val)
608 | 
609 | -- | Size of the receive buffer, in bytes. To prevent blocking for messages
610 | -- larger than the buffer, exactly one message may be buffered in addition
611 | -- to the data in the receive buffer.
612 | --
613 | -- Default value is 128kB.
614 | rcvBuf :: Socket a -> IO Int
615 | rcvBuf s =
616 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RCVBUF)
617 | 
618 | -- | Size of the receive buffer, in bytes. To prevent blocking for messages
619 | -- larger than the buffer, exactly one message may be buffered in addition
620 | -- to the data in the receive buffer.
621 | --
622 | -- Default value is 128kB.
623 | setRcvBuf :: Socket a -> Int -> IO ()
624 | setRcvBuf s val =
625 |     setOption s (#const NN_SOL_SOCKET) (#const NN_RCVBUF) (IntOption val)
626 | 
627 | -- | Maximum message size that can be received, in bytes.
628 | -- Negative value means that the received size is limited only by available addressable memory.
629 | -- The type of this option is int.
630 | --
631 | -- Default is 1024kB.
632 | rcvMaxSize :: Socket a -> IO Int
633 | rcvMaxSize s =
634 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RCVMAXSIZE)
635 | 
636 | -- | Maximum message size that can be received, in bytes.
637 | -- Negative value means that the received size is limited only by available addressable memory.
638 | -- The type of this option is int.
639 | --
640 | -- Default is 1024kB.
641 | setRcvMaxSize :: Socket a -> Int -> IO ()
642 | setRcvMaxSize s val =
643 |     setOption s (#const NN_SOL_SOCKET) (#const NN_RCVMAXSIZE) (IntOption val)
644 | 
645 | -- Think I'll just skip these. There's recv' for nonblocking receive, and
646 | -- adding a return value to send seems awkward.
647 | --sendTimeout
648 | --recvTimeout
649 | 
650 | -- | For connection-based transports such as TCP, this option specifies
651 | -- how long to wait, in milliseconds, when connection is broken before
652 | -- trying to re-establish it.
653 | --
654 | -- Note that actual reconnect interval may be randomised to some extent
655 | -- to prevent severe reconnection storms.
656 | --
657 | -- Default value is 100 (0.1 second).
658 | reconnectInterval :: Socket a -> IO Int
659 | reconnectInterval s =
660 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL)
661 | 
662 | -- | For connection-based transports such as TCP, this option specifies
663 | -- how long to wait, in milliseconds, when connection is broken before
664 | -- trying to re-establish it.
665 | --
666 | -- Note that actual reconnect interval may be randomised to some extent
667 | -- to prevent severe reconnection storms.
668 | --
669 | -- Default value is 100 (0.1 second).
670 | setReconnectInterval :: Socket a -> Int -> IO ()
671 | setReconnectInterval s val =
672 |     setOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL) (IntOption val)
673 | 
674 | -- | This option is to be used only in addition to NN_RECONNECT_IVL option.
675 | -- It specifies maximum reconnection interval. On each reconnect attempt,
676 | -- the previous interval is doubled until NN_RECONNECT_IVL_MAX is reached.
677 | --
678 | -- Value of zero means that no exponential backoff is performed and reconnect
679 | -- interval is based only on NN_RECONNECT_IVL. If NN_RECONNECT_IVL_MAX is
680 | -- less than NN_RECONNECT_IVL, it is ignored.
681 | --
682 | -- Default value is 0.
683 | reconnectIntervalMax :: Socket a -> IO Int
684 | reconnectIntervalMax s =
685 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL_MAX)
686 | 
687 | -- | This option is to be used only in addition to NN_RECONNECT_IVL option.
688 | -- It specifies maximum reconnection interval. On each reconnect attempt,
689 | -- the previous interval is doubled until NN_RECONNECT_IVL_MAX is reached.
690 | --
691 | -- Value of zero means that no exponential backoff is performed and reconnect
692 | -- interval is based only on NN_RECONNECT_IVL. If NN_RECONNECT_IVL_MAX is
693 | -- less than NN_RECONNECT_IVL, it is ignored.
694 | --
695 | -- Default value is 0.
696 | setReconnectIntervalMax :: Socket a -> Int -> IO ()
697 | setReconnectIntervalMax s val =
698 |     setOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL_MAX) (IntOption val)
699 | 
700 | -- | Sets outbound priority for endpoints subsequently added to the socket.
701 | -- This option has no effect on socket types that send messages to all the
702 | -- peers. However, if the socket type sends each message to a single peer
703 | -- (or a limited set of peers), peers with high priority take precedence over
704 | -- peers with low priority.
705 | --
706 | -- Highest priority is 1, lowest priority is 16. Default value is 8.
707 | sndPrio :: Socket a -> IO Int
708 | sndPrio s =
709 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_SNDPRIO)
710 | 
711 | -- | Sets outbound priority for endpoints subsequently added to the socket.
712 | -- This option has no effect on socket types that send messages to all the
713 | -- peers. However, if the socket type sends each message to a single peer
714 | -- (or a limited set of peers), peers with high priority take precedence over
715 | -- peers with low priority.
716 | --
717 | -- Highest priority is 1, lowest priority is 16. Default value is 8.
718 | setSndPrio :: Socket a -> Int -> IO ()
719 | setSndPrio s val =
720 |     setOption s (#const NN_SOL_SOCKET) (#const NN_SNDPRIO) (IntOption val)
721 | 
722 | -- | If set to 1, only IPv4 addresses are used. If set to 0, both IPv4
723 | -- and IPv6 addresses are used.
724 | --
725 | -- Default value is 1.
726 | ipv4Only :: Socket a -> IO Int
727 | ipv4Only s =
728 |     fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_IPV4ONLY)
729 | 
730 | -- | If set to 1, only IPv4 addresses are used. If set to 0, both IPv4
731 | -- and IPv6 addresses are used.
732 | --
733 | -- Default value is 1.
734 | setIpv4Only :: Socket a -> Int -> IO ()
735 | setIpv4Only s val =
736 |     setOption s (#const NN_SOL_SOCKET) (#const NN_IPV4ONLY) (IntOption val)
737 | 
738 | -- | This option is defined on the full REQ socket. If reply is not received
739 | -- in specified amount of milliseconds, the request will be automatically
740 | -- resent.
741 | --
742 | -- Default value is 60000 (1 minute).
743 | requestResendInterval :: Socket Req -> IO Int
744 | requestResendInterval s =
745 |     fromIntegral <$> getOption s (#const NN_REQ) (#const NN_REQ_RESEND_IVL)
746 | 
747 | -- | This option is defined on the full REQ socket. If reply is not received
748 | -- in specified amount of milliseconds, the request will be automatically
749 | -- resent.
750 | --
751 | -- Default value is 60000 (1 minute).
752 | setRequestResendInterval :: Socket Req -> Int -> IO ()
753 | setRequestResendInterval s val =
754 |     setOption s (#const NN_REQ) (#const NN_REQ_RESEND_IVL) (IntOption val)
755 | 
756 | -- | Get timeout for Surveyor sockets
757 | surveyorDeadline :: Socket Surveyor -> IO Int
758 | surveyorDeadline s =
759 |     fromIntegral <$> getOption s (#const NN_SURVEYOR) (#const NN_SURVEYOR_DEADLINE)
760 | 
761 | -- | Set timeout for Surveyor sockets
762 | setSurveyorDeadline :: Socket Surveyor -> Int -> IO ()
763 | setSurveyorDeadline s val =
764 |     setOption s (#const NN_SURVEYOR) (#const NN_SURVEYOR_DEADLINE) (IntOption val)
765 | 
766 | -- | This option, when set to 1, disables Nagle's algorithm.
767 | --
768 | -- Default value is 0.
769 | tcpNoDelay :: Socket a -> IO Int
770 | tcpNoDelay s =
771 |     fromIntegral <$> getOption s (#const NN_TCP) (#const NN_TCP_NODELAY)
772 | 
773 | -- | This option, when set to 1, disables Nagle's algorithm.
774 | --
775 | -- Default value is 0.
776 | setTcpNoDelay :: Socket a -> Int -> IO ()
777 | setTcpNoDelay s val =
778 |     setOption s (#const NN_TCP) (#const NN_TCP_NODELAY) (IntOption val)
779 | 
780 | 


--------------------------------------------------------------------------------