├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CONTRIBUTORS ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks ├── SendMessages.hs └── Zmq.hs ├── cabal.project ├── changelog ├── nanomsg-haskell.cabal ├── src ├── Nanomsg.hsc └── Nanomsg │ └── Binary.hs └── tests ├── BinaryDriver.hs ├── BinaryProperties.hs ├── PropDriver.hs └── Properties.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci '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.20240708 12 | # 13 | # REGENDATA ("0.19.20240708",["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-20.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.4.7 32 | compilerKind: ghc 33 | compilerVersion: 9.4.7 34 | setup-method: ghcup 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | mkdir -p "$HOME/.ghcup/bin" 43 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 44 | chmod a+x "$HOME/.ghcup/bin/ghcup" 45 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 46 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 47 | env: 48 | HCKIND: ${{ matrix.compilerKind }} 49 | HCNAME: ${{ matrix.compiler }} 50 | HCVER: ${{ matrix.compilerVersion }} 51 | - name: Set PATH and environment variables 52 | run: | 53 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 54 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 55 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 56 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 57 | HCDIR=/opt/$HCKIND/$HCVER 58 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 59 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 60 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 61 | echo "HC=$HC" >> "$GITHUB_ENV" 62 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 63 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 64 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 65 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 66 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 67 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 68 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 69 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 70 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 71 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 72 | env: 73 | HCKIND: ${{ matrix.compilerKind }} 74 | HCNAME: ${{ matrix.compiler }} 75 | HCVER: ${{ matrix.compilerVersion }} 76 | - name: env 77 | run: | 78 | env 79 | - name: write cabal config 80 | run: | 81 | mkdir -p $CABAL_DIR 82 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 115 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 116 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 117 | rm -f cabal-plan.xz 118 | chmod a+x $HOME/.cabal/bin/cabal-plan 119 | cabal-plan --version 120 | - name: checkout 121 | uses: actions/checkout@v4 122 | with: 123 | path: source 124 | - name: initial cabal.project for sdist 125 | run: | 126 | touch cabal.project 127 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 128 | cat cabal.project 129 | - name: sdist 130 | run: | 131 | mkdir -p sdist 132 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 133 | - name: unpack 134 | run: | 135 | mkdir -p unpacked 136 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 137 | - name: generate cabal.project 138 | run: | 139 | PKGDIR_nanomsg_haskell="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/nanomsg-haskell-[0-9.]*')" 140 | echo "PKGDIR_nanomsg_haskell=${PKGDIR_nanomsg_haskell}" >> "$GITHUB_ENV" 141 | rm -f cabal.project cabal.project.local 142 | touch cabal.project 143 | touch cabal.project.local 144 | echo "packages: ${PKGDIR_nanomsg_haskell}" >> cabal.project 145 | echo "package nanomsg-haskell" >> cabal.project 146 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 147 | cat >> cabal.project <> cabal.project.local 150 | cat cabal.project 151 | cat cabal.project.local 152 | - name: dump install plan 153 | run: | 154 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 155 | cabal-plan 156 | - name: restore cache 157 | uses: actions/cache/restore@v4 158 | with: 159 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 160 | path: ~/.cabal/store 161 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 162 | - name: install dependencies 163 | run: | 164 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 165 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 166 | - name: build w/o tests 167 | run: | 168 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 169 | - name: build 170 | run: | 171 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 172 | - name: tests 173 | run: | 174 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 175 | - name: cabal check 176 | run: | 177 | cd ${PKGDIR_nanomsg_haskell} || false 178 | ${CABAL} -vnormal check 179 | - name: haddock 180 | run: | 181 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 182 | - name: unconstrained build 183 | run: | 184 | rm -f cabal.project.local 185 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 186 | - name: save cache 187 | uses: actions/cache/save@v4 188 | if: always() 189 | with: 190 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 191 | path: ~/.cabal/store 192 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox/ 2 | /cabal.sandbox.config 3 | /cabal-dev 4 | /dist 5 | *.swp 6 | /dist-newstyle 7 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Ivar Nymoen 2 | João Cristóvão 3 | Jakub Stasiak 4 | Will Martino 5 | Ben Gamari 6 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # nanomsg-haskell 2 | 3 | This is a Haskell binding for the nanomsg library: . 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 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: true 3 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | 0.2.4 2 | * Bumped upper bound on binary 3 | 0.2.3 4 | * Switched to safe ffi calls to play better with the runtime 5 | * Tests fixed for ghc 7.10 6 | * Some minor tweaks to docs and metadata 7 | 0.2.2 8 | * Added a thin Binary based serialization layer 9 | * Benchmarks now depend on ZMQ4 10 | 11 | -------------------------------------------------------------------------------- /nanomsg-haskell.cabal: -------------------------------------------------------------------------------- 1 | name: nanomsg-haskell 2 | version: 0.2.4 3 | synopsis: 4 | Bindings to the nanomsg library 5 | description: 6 | This is a Haskell binding for the nanomsg library: . 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 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 | extra-source-files: 27 | README.md 28 | , CONTRIBUTORS 29 | , changelog 30 | , tests/*.hs 31 | , benchmarks/*.hs 32 | 33 | library 34 | hs-source-dirs: src 35 | ghc-options: -O2 -Wall -fwarn-tabs 36 | default-language: Haskell2010 37 | exposed-modules: 38 | Nanomsg 39 | Nanomsg.Binary 40 | default-extensions: ForeignFunctionInterface, DeriveDataTypeable 41 | includes: nanomsg/nn.h 42 | extra-libraries: nanomsg 43 | build-depends: 44 | base >= 4.5 && < 5, 45 | bytestring >= 0.9.0 && < 0.13, 46 | binary >= 0.7 && < 0.9 47 | 48 | test-suite tests 49 | type: exitcode-stdio-1.0 50 | hs-source-dirs: tests 51 | main-is: PropDriver.hs 52 | other-modules: BinaryProperties Properties 53 | ghc-options: -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts 54 | default-language: Haskell2010 55 | build-tool-depends: 56 | tasty-discover:tasty-discover 57 | build-depends: 58 | base >= 4.5 && < 5, 59 | bytestring >= 0.9.0 && < 0.13, 60 | nanomsg-haskell, 61 | QuickCheck, 62 | tasty, 63 | tasty-quickcheck, 64 | tasty-discover 65 | 66 | test-suite tests-binary 67 | type: exitcode-stdio-1.0 68 | hs-source-dirs: tests 69 | main-is: BinaryDriver.hs 70 | other-modules: Properties BinaryProperties 71 | ghc-options: -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts 72 | default-language: Haskell2010 73 | build-tool-depends: 74 | tasty-discover:tasty-discover 75 | build-depends: 76 | base >= 4.5 && < 5, 77 | bytestring >= 0.9.0 && < 0.13, 78 | nanomsg-haskell, 79 | binary, 80 | QuickCheck, 81 | tasty, 82 | tasty-quickcheck, 83 | tasty-discover 84 | 85 | source-repository head 86 | type: git 87 | location: https://github.com/ivarnymoen/nanomsg-haskell 88 | 89 | benchmark send-messages 90 | type: exitcode-stdio-1.0 91 | main-is: SendMessages.hs 92 | ghc-options: -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts 93 | default-language: Haskell2010 94 | hs-source-dirs: benchmarks 95 | build-depends: 96 | base >= 4.5 && < 5, 97 | bytestring >= 0.9.0 && < 0.13, 98 | nanomsg-haskell, 99 | criterion 100 | 101 | benchmark vs-zeromq-bindings 102 | type: exitcode-stdio-1.0 103 | main-is: Zmq.hs 104 | ghc-options: -O2 -Wall -fwarn-tabs -threaded "-with-rtsopts=-N" -rtsopts 105 | default-language: Haskell2010 106 | hs-source-dirs: benchmarks 107 | build-depends: 108 | base >= 4.5 && < 5, 109 | bytestring >= 0.9.0 && < 0.13, 110 | nanomsg-haskell, 111 | zeromq4-haskell, 112 | criterion 113 | 114 | -------------------------------------------------------------------------------- /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: . 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 . 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 | , reconnectInterval 63 | , setReconnectInterval 64 | , reconnectIntervalMax 65 | , setReconnectIntervalMax 66 | , sndPrio 67 | , setSndPrio 68 | , ipv4Only 69 | , setIpv4Only 70 | , requestResendInterval 71 | , setRequestResendInterval 72 | , surveyorDeadline 73 | , setSurveyorDeadline 74 | , tcpNoDelay 75 | , setTcpNoDelay 76 | ) where 77 | 78 | #include "nanomsg/nn.h" 79 | #include "nanomsg/pair.h" 80 | #include "nanomsg/reqrep.h" 81 | #include "nanomsg/pubsub.h" 82 | #include "nanomsg/survey.h" 83 | #include "nanomsg/pipeline.h" 84 | #include "nanomsg/bus.h" 85 | #include "nanomsg/tcp.h" 86 | 87 | import Data.ByteString (ByteString) 88 | -- import qualified Data.ByteString.Lazy as L 89 | import qualified Data.ByteString.Char8 as C 90 | import qualified Data.ByteString.Unsafe as U 91 | import Foreign (peek, poke, alloca) 92 | import Foreign.Ptr 93 | import Foreign.C.Types 94 | import Foreign.C.String 95 | import Foreign.Storable (sizeOf) 96 | import Control.Applicative ( (<$>) ) 97 | import Control.Exception.Base (bracket) 98 | import Control.Exception (Exception, throwIO) 99 | import Data.Typeable (Typeable) 100 | import Control.Monad (void) 101 | import Text.Printf (printf) 102 | import Control.Concurrent (threadWaitRead, threadWaitWrite) 103 | import System.Posix.Types (Fd(..)) 104 | 105 | 106 | -- * Data and typedefs 107 | 108 | -- | Socket for communication with exactly one peer. Each 109 | -- party can send messages at any time. If the peer is not 110 | -- available or the send buffer is full, subsequent calls 111 | -- will block until it’s possible to send the message. 112 | data Pair = Pair 113 | 114 | -- | Request socket. Pairs with 'Rep' sockets. 115 | -- 116 | -- The socket will resend requests automatically 117 | -- if there's no reply within a given time. The default timeout 118 | -- is 1 minute. 119 | -- 120 | -- See also 'Rep', 'setRequestResendInterval'. 121 | data Req = Req 122 | 123 | -- | Reply socket. 124 | -- 125 | -- See also 'Req'. 126 | data Rep = Rep 127 | 128 | -- | Publish socket. Pairs with subscribe sockets. 129 | -- 130 | -- See also 'Sub'. 131 | data Pub = Pub 132 | 133 | -- | Subscribe socket. 134 | -- 135 | -- Only messages that the socket is subscribed to are received. When the socket 136 | -- is created there are no subscriptions and thus no messages will be received. 137 | -- 138 | -- See also 'Pub', 'subscribe' and 'unsubscribe'. 139 | data Sub = Sub 140 | 141 | -- | Surveyor and respondent are used to broadcast a survey to multiple 142 | -- locations and gather the responses. 143 | -- 144 | -- This socket is used to send a survey. The survey is delivered to all 145 | -- onnected respondents. Once the query is sent, the socket can be used 146 | -- to receive the responses. 147 | -- 148 | -- When the survey deadline expires, receive will throw an NNException. 149 | -- 150 | -- See also 'Respondent', 'setSurveyorDeadline'. 151 | data Surveyor = Surveyor 152 | 153 | -- | Used to respond to a survey. Survey is received using receive, 154 | -- response is sent using send. This socket can be connected to 155 | -- at most one peer. 156 | -- 157 | -- See also 'Surveyor'. 158 | data Respondent = Respondent 159 | 160 | -- | Push and Pull sockets fair queue messages from one processing step, load 161 | -- balancing them among instances of the next processing step. 162 | -- 163 | -- See also 'Pull'. 164 | data Push = Push 165 | 166 | -- | Pull socket. 167 | -- 168 | -- See also 'Push'. 169 | data Pull = Pull 170 | 171 | -- | Broadcasts messages from any node to all other nodes in the topology. 172 | -- The socket should never receives messages that it sent itself. 173 | data Bus = Bus 174 | 175 | -- | Endpoint identifier. Created by 'connect' or 'bind'. 176 | -- 177 | -- Close connections using 'shutdown'. 178 | data Endpoint = Endpoint CInt 179 | deriving (Eq, Show) 180 | 181 | -- | Sockets are created by 'socket' and connections are established with 'connect' or 'bind'. 182 | -- 183 | -- Free sockets using 'close'. 184 | data Socket a = Socket a CInt 185 | deriving (Eq, Show) 186 | 187 | -- | Typeclass for all sockets 188 | class SocketType a where 189 | socketType :: a -> CInt -- ^ Returns the C enum value for each type. E.g. Pair => #const NN_PAIR 190 | 191 | instance SocketType Pair where 192 | socketType Pair = #const NN_PAIR 193 | 194 | instance SocketType Req where 195 | socketType Req = #const NN_REQ 196 | 197 | instance SocketType Rep where 198 | socketType Rep = #const NN_REP 199 | 200 | instance SocketType Pub where 201 | socketType Pub = #const NN_PUB 202 | 203 | instance SocketType Sub where 204 | socketType Sub = #const NN_SUB 205 | 206 | instance SocketType Surveyor where 207 | socketType Surveyor = #const NN_SURVEYOR 208 | 209 | instance SocketType Respondent where 210 | socketType Respondent = #const NN_RESPONDENT 211 | 212 | instance SocketType Push where 213 | socketType Push = #const NN_PUSH 214 | 215 | instance SocketType Pull where 216 | socketType Pull = #const NN_PULL 217 | 218 | instance SocketType Bus where 219 | socketType Bus = #const NN_BUS 220 | 221 | 222 | -- | Typeclass restricting which sockets can use the send function. 223 | class (SocketType a) => Sender a 224 | instance Sender Pair 225 | instance Sender Req 226 | instance Sender Rep 227 | instance Sender Pub 228 | instance Sender Surveyor 229 | instance Sender Respondent 230 | instance Sender Push 231 | instance Sender Bus 232 | 233 | -- | Typeclass for sockets that implement recv 234 | class (SocketType a) => Receiver a 235 | instance Receiver Pair 236 | instance Receiver Req 237 | instance Receiver Rep 238 | instance Receiver Sub 239 | instance Receiver Surveyor 240 | instance Receiver Respondent 241 | instance Receiver Pull 242 | instance Receiver Bus 243 | 244 | 245 | -- * Error handling 246 | -- 247 | -- Reimplementing some of Foreign.C.Error here, to substitute nanomsg's errno 248 | -- and strerror functions for the posix ones. 249 | 250 | -- | Pretty much any error condition throws this exception. 251 | data NNException = NNException String 252 | deriving (Eq, Show, Typeable) 253 | 254 | instance Exception NNException 255 | 256 | mkErrorString :: String -> IO String 257 | mkErrorString loc = do 258 | errNo <- c_nn_errno 259 | errCString <- c_nn_strerror errNo 260 | errString <- peekCString errCString 261 | return $ printf "nanomsg-haskell error at %s. Errno %d: %s" loc (fromIntegral errNo :: Int) errString 262 | 263 | throwErrno :: String -> IO a 264 | throwErrno loc = do 265 | s <- mkErrorString loc 266 | throwIO $ NNException s 267 | 268 | throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a 269 | throwErrnoIf p loc action = do 270 | res <- action 271 | if p res then throwErrno loc else return res 272 | 273 | throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO () 274 | throwErrnoIf_ p loc action = void $ throwErrnoIf p loc action 275 | 276 | throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a 277 | throwErrnoIfMinus1 = throwErrnoIf (== -1) 278 | 279 | throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () 280 | throwErrnoIfMinus1_ = throwErrnoIf_ (== -1) 281 | 282 | throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a 283 | throwErrnoIfRetry p loc f = do 284 | res <- f 285 | if p res 286 | then do 287 | err <- c_nn_errno 288 | if err == (#const EAGAIN) || err == (#const EINTR) 289 | then throwErrnoIfRetry p loc f 290 | else throwErrno loc 291 | else return res 292 | 293 | throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () 294 | throwErrnoIfRetry_ p loc f = void $ throwErrnoIfRetry p loc f 295 | 296 | {- 297 | throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a 298 | throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) 299 | -} 300 | 301 | throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO () 302 | throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) 303 | 304 | throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a 305 | throwErrnoIfRetryMayBlock p loc f on_block = do 306 | res <- f 307 | if p res 308 | then do 309 | err <- c_nn_errno 310 | if err `elem` [ (#const EAGAIN), (#const EINTR), (#const EWOULDBLOCK) ] 311 | then do 312 | void on_block 313 | throwErrnoIfRetryMayBlock p loc f on_block 314 | else throwErrno loc 315 | else return res 316 | 317 | throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () 318 | throwErrnoIfRetryMayBlock_ p loc f on_block = void $ throwErrnoIfRetryMayBlock p loc f on_block 319 | 320 | throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a) => String -> IO a -> IO b -> IO a 321 | throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1) 322 | 323 | throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a) => String -> IO a -> IO b -> IO () 324 | throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1) 325 | 326 | 327 | -- * FFI functions 328 | 329 | -- NN_EXPORT int nn_socket (int domain, int protocol); 330 | foreign import ccall safe "nn.h nn_socket" 331 | c_nn_socket :: CInt -> CInt -> IO CInt 332 | 333 | -- NN_EXPORT int nn_bind (int s, const char *addr); 334 | foreign import ccall safe "nn.h nn_bind" 335 | c_nn_bind :: CInt -> CString -> IO CInt 336 | 337 | -- NN_EXPORT int nn_connect (int s, const char *addr); 338 | foreign import ccall safe "nn.h nn_connect" 339 | c_nn_connect :: CInt -> CString -> IO CInt 340 | 341 | -- NN_EXPORT int nn_shutdown (int s, int how); 342 | foreign import ccall safe "nn.h nn_shutdown" 343 | c_nn_shutdown :: CInt -> CInt -> IO CInt 344 | 345 | -- NN_EXPORT int nn_send (int s, const void *buf, size_t len, int flags); 346 | foreign import ccall safe "nn.h nn_send" 347 | c_nn_send :: CInt -> CString -> CInt -> CInt -> IO CInt 348 | 349 | -- NN_EXPORT int nn_recv (int s, void *buf, size_t len, int flags); 350 | foreign import ccall safe "nn.h nn_recv" 351 | c_nn_recv :: CInt -> Ptr CString -> CInt -> CInt -> IO CInt 352 | 353 | -- NN_EXPORT int nn_freemsg (void *msg); 354 | foreign import ccall safe "nn.h nn_freemsg" 355 | c_nn_freemsg :: Ptr CChar -> IO CInt 356 | 357 | -- NN_EXPORT int nn_close (int s); 358 | foreign import ccall safe "nn.h nn_close" 359 | c_nn_close :: CInt -> IO CInt 360 | 361 | -- NN_EXPORT void nn_term (void); 362 | foreign import ccall safe "nn.h nn_term" 363 | c_nn_term :: IO () 364 | 365 | -- NN_EXPORT int nn_setsockopt (int s, int level, int option, const void *optval, size_t optvallen); 366 | foreign import ccall safe "nn.h nn_setsockopt" 367 | c_nn_setsockopt :: CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt 368 | 369 | -- NN_EXPORT int nn_getsockopt (int s, int level, int option, void *optval, size_t *optvallen); 370 | foreign import ccall safe "nn.h nn_getsockopt" 371 | c_nn_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt 372 | 373 | -- /* Resolves system errors and native errors to human-readable string. */ 374 | -- NN_EXPORT const char *nn_strerror (int errnum); 375 | foreign import ccall safe "nn.h nn_strerror" 376 | c_nn_strerror :: CInt -> IO CString 377 | 378 | -- /* This function retrieves the errno as it is known to the library. */ 379 | -- /* The goal of this function is to make the code 100% portable, including */ 380 | -- /* where the library is compiled with certain CRT library (on Windows) and */ 381 | -- /* linked to an application that uses different CRT library. */ 382 | -- NN_EXPORT int nn_errno (void); 383 | foreign import ccall safe "nn.h nn_errno" 384 | c_nn_errno :: IO CInt 385 | 386 | {- 387 | 388 | Unbound FFI functions: 389 | 390 | NN_EXPORT int nn_sendmsg (int s, const struct nn_msghdr *msghdr, int flags); 391 | NN_EXPORT int nn_recvmsg (int s, struct nn_msghdr *msghdr, int flags); 392 | 393 | NN_EXPORT void *nn_allocmsg (size_t size, int type); 394 | -} 395 | 396 | -- * Operations 397 | 398 | -- | Creates a socket. Connections are formed using 'bind' or 'connect'. 399 | -- 400 | -- See also: 'close'. 401 | socket :: (SocketType a) => a -> IO (Socket a) 402 | socket t = do 403 | sid <- throwErrnoIfMinus1 "socket" $ c_nn_socket (#const AF_SP) (socketType t) 404 | return $ Socket t sid 405 | 406 | -- | Creates a socket and runs your action with it. 407 | -- 408 | -- E.g. collecting 10 messages: 409 | -- 410 | -- > withSocket Sub $ \sub -> do 411 | -- > _ <- connect sub "tcp://localhost:5560" 412 | -- > subscribe sub (C.pack "") 413 | -- > replicateM 10 (recv sub) 414 | -- 415 | -- Ensures the socket is closed when your action is done. 416 | withSocket :: (SocketType a) => a -> (Socket a -> IO b) -> IO b 417 | withSocket t = bracket (socket t) close 418 | 419 | -- | Binds the socket to a local interface. 420 | -- 421 | -- See the nanomsg documentation for specifics on transports. 422 | -- Note that host names do not work for tcp. Some examples are: 423 | -- 424 | -- > bind sock "tcp://*:5560" 425 | -- > bind sock "tcp://eth0:5560" 426 | -- > bind sock "tcp://127.0.0.1:5560" 427 | -- > bind sock "inproc://test" 428 | -- > bind sock "ipc:///tmp/test.ipc" 429 | -- 430 | -- This function returns an 'Endpoint', which can be supplied 431 | -- to 'shutdown' to remove a connection. 432 | -- 433 | -- See also: 'connect', 'shutdown'. 434 | bind :: Socket a -> String -> IO Endpoint 435 | bind (Socket _ sid) addr = 436 | withCString addr $ \adr -> do 437 | epid <- throwErrnoIfMinus1 "bind" $ c_nn_bind sid adr 438 | return $ Endpoint epid 439 | 440 | -- | Connects the socket to an endpoint. 441 | -- 442 | -- e.g. : 443 | -- 444 | -- > connect sock "tcp://localhost:5560" 445 | -- > connect sock "inproc://test" 446 | -- 447 | -- See also: 'bind', 'shutdown'. 448 | connect :: Socket a -> String -> IO Endpoint 449 | connect (Socket _ sid) addr = 450 | withCString addr $ \adr -> do 451 | epid <- throwErrnoIfMinus1 "connect" $ c_nn_connect sid adr 452 | return $ Endpoint epid 453 | 454 | -- | Removes an endpoint from a socket. 455 | -- 456 | -- See also: 'bind', 'connect'. 457 | shutdown :: Socket a -> Endpoint -> IO () 458 | shutdown (Socket _ sid) (Endpoint eid) = 459 | throwErrnoIfMinus1_ "shutdown" $ c_nn_shutdown sid eid 460 | 461 | -- | Blocking function for sending a message 462 | -- 463 | -- See also: 'recv', 'recv''. 464 | send :: Sender a => Socket a -> ByteString -> IO () 465 | send (Socket t sid) string = 466 | U.unsafeUseAsCStringLen string $ \(ptr, len) -> 467 | throwErrnoIfMinus1RetryMayBlock_ 468 | "send" 469 | (c_nn_send sid ptr (fromIntegral len) (#const NN_DONTWAIT)) 470 | (getOptionFd (Socket t sid) (#const NN_SNDFD) >>= threadWaitWrite) 471 | 472 | -- | Blocking receive. 473 | recv :: Receiver a => Socket a -> IO ByteString 474 | recv (Socket t sid) = 475 | alloca $ \ptr -> do 476 | len <- throwErrnoIfMinus1RetryMayBlock 477 | "recv" 478 | (c_nn_recv sid ptr (#const NN_MSG) (#const NN_DONTWAIT)) 479 | (getOptionFd (Socket t sid) (#const NN_RCVFD) >>= threadWaitRead) 480 | buf <- peek ptr 481 | str <- C.packCStringLen (buf, fromIntegral len) 482 | throwErrnoIfMinus1_ "recv freeing message buffer" $ c_nn_freemsg buf 483 | return str 484 | 485 | -- | Nonblocking receive function. 486 | recv' :: Receiver a => Socket a -> IO (Maybe ByteString) 487 | recv' (Socket _ sid) = 488 | alloca $ \ptr -> do 489 | len <- c_nn_recv sid ptr (#const NN_MSG) (#const NN_DONTWAIT) 490 | if len >= 0 491 | then do 492 | buf <- peek ptr 493 | str <- C.packCStringLen (buf, fromIntegral len) 494 | throwErrnoIfMinus1_ "recv' freeing message buffer" $ c_nn_freemsg buf 495 | return $ Just str 496 | else do 497 | errno <- c_nn_errno 498 | if errno == (#const EAGAIN) || errno == (#const EINTR) 499 | then return Nothing 500 | else throwErrno "recv'" 501 | 502 | -- | Subscribe to a given subject string. 503 | subscribe :: Socket Sub -> ByteString -> IO () 504 | subscribe (Socket t sid) string = 505 | setOption (Socket t sid) (socketType t) (#const NN_SUB_SUBSCRIBE) (StringOption string) 506 | 507 | -- | Unsubscribes from a subject. 508 | unsubscribe :: Socket Sub -> ByteString -> IO () 509 | unsubscribe (Socket t sid) string = 510 | setOption (Socket t sid) (socketType t) (#const NN_SUB_UNSUBSCRIBE) (StringOption string) 511 | 512 | -- | Closes the socket. Any buffered inbound messages that were not yet 513 | -- received by the application will be discarded. The library will try to 514 | -- deliver any outstanding outbound messages for the time specified by 515 | -- NN_LINGER socket option. The call will block in the meantime. 516 | close :: Socket a -> IO () 517 | close (Socket _ sid) = 518 | throwErrnoIfMinus1Retry_ "close" $ c_nn_close sid 519 | 520 | -- | Switches nanomsg into shutdown modus and interrupts any waiting 521 | -- function calls. 522 | term :: IO () 523 | term = c_nn_term 524 | 525 | 526 | -- * Socket option accessors and mutators 527 | 528 | -- not sure if this beats having setOptionInt and setOptionString.. 529 | data SocketOption = IntOption Int | StringOption ByteString 530 | deriving (Show) 531 | 532 | -- Used for setting a socket option. 533 | setOption :: Socket a -> CInt -> CInt -> SocketOption -> IO () 534 | 535 | setOption (Socket _ sid) level option (IntOption val) = 536 | alloca $ \ptr -> do 537 | poke ptr (fromIntegral val :: CInt) 538 | let cintSize = fromIntegral $ sizeOf (fromIntegral val :: CInt) :: CInt 539 | throwErrnoIfMinus1_ "setOption (int)" $ c_nn_setsockopt sid level option ptr cintSize 540 | 541 | setOption (Socket _ sid) level option (StringOption str) = 542 | throwErrnoIfMinus1_ "setOption (string)" <$> U.unsafeUseAsCStringLen str $ 543 | \(ptr, len) -> c_nn_setsockopt sid level option ptr (fromIntegral len) 544 | 545 | -- Reads a socket option. 546 | getOption :: Socket a -> CInt -> CInt -> IO CInt 547 | getOption (Socket _ sid) level option = 548 | alloca $ \ptr -> 549 | alloca $ \sizePtr -> do 550 | let a = 1 :: CInt 551 | let cintSize = fromIntegral $ sizeOf a 552 | poke sizePtr cintSize 553 | throwErrnoIfMinus1_ "getOption" $ c_nn_getsockopt sid level option (ptr :: Ptr CInt) sizePtr 554 | value <- peek ptr 555 | size <- peek sizePtr 556 | if cintSize /= size then throwErrno "getOption: output size not as expected" else return value 557 | 558 | -- Retrieves a nanomsg file descriptor for polling ready status. 559 | getOptionFd :: Socket a -> CInt -> IO Fd 560 | getOptionFd (Socket _ sid) option = 561 | alloca $ \ptr -> 562 | alloca $ \sizePtr -> do 563 | let a = 1 :: Fd 564 | let fdSize = fromIntegral $ sizeOf a 565 | poke sizePtr fdSize 566 | throwErrnoIfMinus1_ "getOptionFd" $ c_nn_getsockopt sid (#const NN_SOL_SOCKET) option (ptr :: Ptr Fd) sizePtr 567 | value <- peek ptr 568 | size <- peek sizePtr 569 | if fdSize /= size then throwErrno "getOptionFd: output size not as expected" else return value 570 | 571 | -- | Specifies how long the socket should try to send pending outbound 572 | -- messages after close has been called, in milliseconds. 573 | -- 574 | -- Negative value means infinite linger. Default value is 1000 (1 second). 575 | linger :: Socket a -> IO Int 576 | linger s = 577 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_LINGER) 578 | 579 | -- | Specifies how long should the socket try to send pending outbound 580 | -- messages after close has been called, in milliseconds. 581 | -- 582 | -- Negative value means infinite linger. Default value is 1000 (1 second). 583 | setLinger :: Socket a -> Int -> IO () 584 | setLinger s val = 585 | setOption s (#const NN_SOL_SOCKET) (#const NN_LINGER) (IntOption val) 586 | 587 | -- | Size of the send buffer, in bytes. To prevent blocking for messages 588 | -- larger than the buffer, exactly one message may be buffered in addition 589 | -- to the data in the send buffer. 590 | -- 591 | -- Default value is 128kB. 592 | sndBuf :: Socket a -> IO Int 593 | sndBuf s = 594 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_SNDBUF) 595 | 596 | -- | Size of the send buffer, in bytes. To prevent blocking for messages 597 | -- larger than the buffer, exactly one message may be buffered in addition 598 | -- to the data in the send buffer. 599 | -- 600 | -- Default value is 128kB. 601 | setSndBuf :: Socket a -> Int -> IO () 602 | setSndBuf s val = 603 | setOption s (#const NN_SOL_SOCKET) (#const NN_SNDBUF) (IntOption val) 604 | 605 | -- | Size of the receive buffer, in bytes. To prevent blocking for messages 606 | -- larger than the buffer, exactly one message may be buffered in addition 607 | -- to the data in the receive buffer. 608 | -- 609 | -- Default value is 128kB. 610 | rcvBuf :: Socket a -> IO Int 611 | rcvBuf s = 612 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RCVBUF) 613 | 614 | -- | Size of the receive buffer, in bytes. To prevent blocking for messages 615 | -- larger than the buffer, exactly one message may be buffered in addition 616 | -- to the data in the receive buffer. 617 | -- 618 | -- Default value is 128kB. 619 | setRcvBuf :: Socket a -> Int -> IO () 620 | setRcvBuf s val = 621 | setOption s (#const NN_SOL_SOCKET) (#const NN_RCVBUF) (IntOption val) 622 | 623 | -- Think I'll just skip these. There's recv' for nonblocking receive, and 624 | -- adding a return value to send seems awkward. 625 | --sendTimeout 626 | --recvTimeout 627 | 628 | -- | For connection-based transports such as TCP, this option specifies 629 | -- how long to wait, in milliseconds, when connection is broken before 630 | -- trying to re-establish it. 631 | -- 632 | -- Note that actual reconnect interval may be randomised to some extent 633 | -- to prevent severe reconnection storms. 634 | -- 635 | -- Default value is 100 (0.1 second). 636 | reconnectInterval :: Socket a -> IO Int 637 | reconnectInterval s = 638 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL) 639 | 640 | -- | For connection-based transports such as TCP, this option specifies 641 | -- how long to wait, in milliseconds, when connection is broken before 642 | -- trying to re-establish it. 643 | -- 644 | -- Note that actual reconnect interval may be randomised to some extent 645 | -- to prevent severe reconnection storms. 646 | -- 647 | -- Default value is 100 (0.1 second). 648 | setReconnectInterval :: Socket a -> Int -> IO () 649 | setReconnectInterval s val = 650 | setOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL) (IntOption val) 651 | 652 | -- | This option is to be used only in addition to NN_RECONNECT_IVL option. 653 | -- It specifies maximum reconnection interval. On each reconnect attempt, 654 | -- the previous interval is doubled until NN_RECONNECT_IVL_MAX is reached. 655 | -- 656 | -- Value of zero means that no exponential backoff is performed and reconnect 657 | -- interval is based only on NN_RECONNECT_IVL. If NN_RECONNECT_IVL_MAX is 658 | -- less than NN_RECONNECT_IVL, it is ignored. 659 | -- 660 | -- Default value is 0. 661 | reconnectIntervalMax :: Socket a -> IO Int 662 | reconnectIntervalMax s = 663 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL_MAX) 664 | 665 | -- | This option is to be used only in addition to NN_RECONNECT_IVL option. 666 | -- It specifies maximum reconnection interval. On each reconnect attempt, 667 | -- the previous interval is doubled until NN_RECONNECT_IVL_MAX is reached. 668 | -- 669 | -- Value of zero means that no exponential backoff is performed and reconnect 670 | -- interval is based only on NN_RECONNECT_IVL. If NN_RECONNECT_IVL_MAX is 671 | -- less than NN_RECONNECT_IVL, it is ignored. 672 | -- 673 | -- Default value is 0. 674 | setReconnectIntervalMax :: Socket a -> Int -> IO () 675 | setReconnectIntervalMax s val = 676 | setOption s (#const NN_SOL_SOCKET) (#const NN_RECONNECT_IVL_MAX) (IntOption val) 677 | 678 | -- | Sets outbound priority for endpoints subsequently added to the socket. 679 | -- This option has no effect on socket types that send messages to all the 680 | -- peers. However, if the socket type sends each message to a single peer 681 | -- (or a limited set of peers), peers with high priority take precedence over 682 | -- peers with low priority. 683 | -- 684 | -- Highest priority is 1, lowest priority is 16. Default value is 8. 685 | sndPrio :: Socket a -> IO Int 686 | sndPrio s = 687 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_SNDPRIO) 688 | 689 | -- | Sets outbound priority for endpoints subsequently added to the socket. 690 | -- This option has no effect on socket types that send messages to all the 691 | -- peers. However, if the socket type sends each message to a single peer 692 | -- (or a limited set of peers), peers with high priority take precedence over 693 | -- peers with low priority. 694 | -- 695 | -- Highest priority is 1, lowest priority is 16. Default value is 8. 696 | setSndPrio :: Socket a -> Int -> IO () 697 | setSndPrio s val = 698 | setOption s (#const NN_SOL_SOCKET) (#const NN_SNDPRIO) (IntOption val) 699 | 700 | -- | If set to 1, only IPv4 addresses are used. If set to 0, both IPv4 701 | -- and IPv6 addresses are used. 702 | -- 703 | -- Default value is 1. 704 | ipv4Only :: Socket a -> IO Int 705 | ipv4Only s = 706 | fromIntegral <$> getOption s (#const NN_SOL_SOCKET) (#const NN_IPV4ONLY) 707 | 708 | -- | If set to 1, only IPv4 addresses are used. If set to 0, both IPv4 709 | -- and IPv6 addresses are used. 710 | -- 711 | -- Default value is 1. 712 | setIpv4Only :: Socket a -> Int -> IO () 713 | setIpv4Only s val = 714 | setOption s (#const NN_SOL_SOCKET) (#const NN_IPV4ONLY) (IntOption val) 715 | 716 | -- | This option is defined on the full REQ socket. If reply is not received 717 | -- in specified amount of milliseconds, the request will be automatically 718 | -- resent. 719 | -- 720 | -- Default value is 60000 (1 minute). 721 | requestResendInterval :: Socket Req -> IO Int 722 | requestResendInterval s = 723 | fromIntegral <$> getOption s (#const NN_REQ) (#const NN_REQ_RESEND_IVL) 724 | 725 | -- | This option is defined on the full REQ socket. If reply is not received 726 | -- in specified amount of milliseconds, the request will be automatically 727 | -- resent. 728 | -- 729 | -- Default value is 60000 (1 minute). 730 | setRequestResendInterval :: Socket Req -> Int -> IO () 731 | setRequestResendInterval s val = 732 | setOption s (#const NN_REQ) (#const NN_REQ_RESEND_IVL) (IntOption val) 733 | 734 | -- | Get timeout for Surveyor sockets 735 | surveyorDeadline :: Socket Surveyor -> IO Int 736 | surveyorDeadline s = 737 | fromIntegral <$> getOption s (#const NN_SURVEYOR) (#const NN_SURVEYOR_DEADLINE) 738 | 739 | -- | Set timeout for Surveyor sockets 740 | setSurveyorDeadline :: Socket Surveyor -> Int -> IO () 741 | setSurveyorDeadline s val = 742 | setOption s (#const NN_SURVEYOR) (#const NN_SURVEYOR_DEADLINE) (IntOption val) 743 | 744 | -- | This option, when set to 1, disables Nagle's algorithm. 745 | -- 746 | -- Default value is 0. 747 | tcpNoDelay :: Socket a -> IO Int 748 | tcpNoDelay s = 749 | fromIntegral <$> getOption s (#const NN_TCP) (#const NN_TCP_NODELAY) 750 | 751 | -- | This option, when set to 1, disables Nagle's algorithm. 752 | -- 753 | -- Default value is 0. 754 | setTcpNoDelay :: Socket a -> Int -> IO () 755 | setTcpNoDelay s val = 756 | setOption s (#const NN_TCP) (#const NN_TCP_NODELAY) (IntOption val) 757 | 758 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tests/BinaryDriver.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover -optF --ignores="Properties.hs" #-} 2 | -------------------------------------------------------------------------------- /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 Data.ByteString (ByteString) 9 | import qualified Data.ByteString.Char8 as C 10 | import Control.Concurrent (threadDelay) 11 | import Control.Applicative ( (<$>) ) 12 | import Data.Maybe (catMaybes) 13 | 14 | instance Arbitrary ByteString where 15 | arbitrary = C.pack <$> arbitrary 16 | 17 | -- dummy test 18 | prop_reverse :: [Int] -> Bool 19 | prop_reverse xs = 20 | xs == reverse (reverse xs) 21 | 22 | type MsgType = PropertyM IO [String] 23 | 24 | -- test Pub and Sub sockets 25 | prop_PubSub :: Property 26 | prop_PubSub = monadicIO $ do 27 | msgs <- pick arbitrary :: MsgType 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 <- pick arbitrary :: MsgType 65 | let recvS :: (Receiver a) => Socket a -> IO String 66 | recvS = recv 67 | pre $ not (null msgs) 68 | res <- run $ do 69 | s1 <- socket Pair 70 | _ <- bind s1 "inproc://pair" 71 | s2 <- socket Pair 72 | _ <- connect s2 "inproc://pair" 73 | threadDelay 1000 74 | -- Send message from s1 to s2, then back from s2 to s1, then make sure it hasn't changed 75 | r <- mapM (\m -> send s1 m >> recvS s2 >>= send s2 >> recv s1 >>= return . (== m)) msgs 76 | close s1 77 | close s2 78 | threadDelay 1000 79 | return r 80 | assert $ and res 81 | 82 | -- test Pipeline (Push & Pull) sockets 83 | prop_Pipeline :: Property 84 | prop_Pipeline = monadicIO $ do 85 | msgs <- pick arbitrary :: MsgType 86 | pre $ not (null msgs) 87 | res <- run $ do 88 | push <- socket Push 89 | _ <- bind push "inproc://pipeline" 90 | pull1 <- socket Pull 91 | pull2 <- socket Pull 92 | _ <- connect pull1 "inproc://pipeline" 93 | _ <- connect pull2 "inproc://pipeline" 94 | threadDelay 1000 95 | r <- mapM (testSockets push pull1 pull2) msgs 96 | close push 97 | close pull1 98 | close pull2 99 | threadDelay 1000 100 | return r 101 | assert $ and res 102 | where 103 | testSockets push pull1 pull2 msg = do 104 | send push msg 105 | send push msg 106 | send push msg 107 | threadDelay 1000 108 | a <- recv' pull1 109 | b <- recv' pull1 110 | c <- recv' pull1 111 | d <- recv' pull2 112 | e <- recv' pull2 113 | f <- recv' pull2 114 | let xs = catMaybes [a, b, c, d, e, f] 115 | return $ all (== msg) xs && (length xs == 3) 116 | 117 | -- test Req and Rep sockets 118 | prop_ReqRep :: Property 119 | prop_ReqRep = monadicIO $ do 120 | msgs <- pick arbitrary :: MsgType 121 | let recvS :: (Receiver a) => Socket a -> IO String 122 | recvS = recv 123 | pre $ not (null msgs) 124 | res <- run $ do 125 | req <- socket Req 126 | _ <- bind req "inproc://reqrep" 127 | rep <- socket Rep 128 | _ <- connect rep "inproc://reqrep" 129 | threadDelay 1000 130 | r <- mapM (\m -> send req m >> recvS rep >>= send rep >> recv req >>= return . (== m)) msgs 131 | close req 132 | close rep 133 | threadDelay 1000 134 | return r 135 | assert $ and res 136 | 137 | -- test Bus socket 138 | prop_Bus :: Property 139 | prop_Bus = monadicIO $ do 140 | msgs <- pick arbitrary :: MsgType 141 | pre $ not (null msgs) 142 | res <- run $ do 143 | -- Probably not how you're supposed to connect Bus nodes.. 144 | b1 <- socket Bus 145 | _ <- bind b1 "inproc://bus1" 146 | b2 <- socket Bus 147 | _ <- connect b2 "inproc://bus1" 148 | _ <- bind b2 "inproc://bus2" 149 | b3 <- socket Bus 150 | _ <- connect b3 "inproc://bus2" 151 | _ <- bind b3 "inproc://bus3" 152 | _ <- connect b1 "inproc://bus3" 153 | threadDelay 1000 154 | r <- mapM (testSockets b1 b2 b3) msgs 155 | close b1 156 | close b2 157 | close b3 158 | threadDelay 1000 159 | return r 160 | assert $ and res 161 | where 162 | testSockets b1 b2 b3 msg = do 163 | send b1 msg 164 | a <- recv b2 165 | b <- recv b3 166 | send b2 msg 167 | c <- recv b1 168 | d <- recv b3 169 | send b3 msg 170 | e <- recv b1 171 | f <- recv b2 172 | return $ all (== msg) [a, b, c, d, e, f] 173 | 174 | prop_TestOptions :: Property 175 | prop_TestOptions = monadicIO $ do 176 | res <- run $ do 177 | req <- socket Req 178 | _ <- bind req "tcp://*:5560" 179 | surveyor <- socket Surveyor 180 | _ <- bind surveyor "inproc://surveyor" 181 | threadDelay 1000 182 | setTcpNoDelay req 1 183 | v1 <- tcpNoDelay req 184 | setTcpNoDelay req 0 185 | v2 <- tcpNoDelay req 186 | setRequestResendInterval req 30000 187 | v3 <- requestResendInterval req 188 | setIpv4Only req 0 189 | v4 <- ipv4Only req 190 | setIpv4Only req 1 191 | v5 <- ipv4Only req 192 | setSndPrio req 7 193 | v6 <- sndPrio req 194 | setReconnectInterval req 50 195 | v7 <- reconnectInterval req 196 | setReconnectIntervalMax req 400 197 | v8 <- reconnectIntervalMax req 198 | setRcvBuf req 200000 199 | v9 <- rcvBuf req 200 | setSndBuf req 150000 201 | v10 <- sndBuf req 202 | setLinger req 500 203 | v11 <- linger req 204 | setSurveyorDeadline surveyor 2000 205 | v12 <- surveyorDeadline surveyor 206 | close req 207 | close surveyor 208 | threadDelay 1000 209 | return [v1 == 1, v2 == 0, v3 == 30000, v4 == 0, v5 == 1, v6 == 7, 210 | v7 == 50, v8 == 400, v9 == 200000, v10 == 150000, v11 == 500, v12 == 2000] 211 | assert $ and res 212 | -------------------------------------------------------------------------------- /tests/PropDriver.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | -------------------------------------------------------------------------------- /tests/Properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | module Properties where 5 | 6 | import Nanomsg 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Monadic 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString.Char8 as C 11 | import Control.Concurrent (threadDelay) 12 | import Control.Applicative ( (<$>) ) 13 | import Data.Maybe (catMaybes) 14 | 15 | instance Arbitrary ByteString where 16 | arbitrary = C.pack <$> arbitrary 17 | 18 | -- dummy test 19 | prop_reverse :: [Int] -> Bool 20 | prop_reverse xs = 21 | xs == reverse (reverse xs) 22 | 23 | -- test Pub and Sub sockets 24 | prop_PubSub :: Property 25 | prop_PubSub = monadicIO $ do 26 | (msgs :: [ByteString]) <- pick arbitrary 27 | pre $ not (null msgs) 28 | res <- run $ do 29 | pub <- socket Pub 30 | ep1 <- bind pub "inproc://pubsub" 31 | sub1 <- socket Sub 32 | ep2 <- connect sub1 "inproc://pubsub" 33 | subscribe sub1 $ C.pack "" 34 | sub2 <- socket Sub 35 | ep3 <- connect sub2 "inproc://pubsub" 36 | subscribe sub2 $ C.pack "" 37 | threadDelay 1000 38 | r <- mapM (sendMsg pub sub1 sub2) msgs 39 | unsubscribe sub2 $ C.pack "" 40 | unsubscribe sub1 $ C.pack "" 41 | shutdown sub2 ep3 42 | shutdown sub1 ep2 43 | shutdown pub ep1 44 | close pub 45 | close sub1 46 | close sub2 47 | threadDelay 1000 48 | return r 49 | assert $ and res 50 | where 51 | sendMsg pub sub1 sub2 msg = do 52 | send pub msg 53 | send pub msg 54 | a <- recv sub1 55 | b <- recv sub1 56 | c <- recv sub2 57 | d <- recv sub2 58 | return $ a == msg && b == msg && c == msg && d == msg 59 | 60 | -- test Pair sockets 61 | prop_Pair :: Property 62 | prop_Pair = monadicIO $ do 63 | (msgs :: [ByteString]) <- pick arbitrary 64 | pre $ not (null msgs) 65 | res <- run $ do 66 | s1 <- socket Pair 67 | _ <- bind s1 "inproc://pair" 68 | s2 <- socket Pair 69 | _ <- connect s2 "inproc://pair" 70 | threadDelay 1000 71 | -- Send message from s1 to s2, then back from s2 to s1, then make sure it hasn't changed 72 | r <- mapM (\m -> send s1 m >> recv s2 >>= send s2 >> recv s1 >>= return . (== m)) msgs 73 | close s1 74 | close s2 75 | threadDelay 1000 76 | return r 77 | assert $ and res 78 | 79 | -- test Pipeline (Push & Pull) sockets 80 | prop_Pipeline :: Property 81 | prop_Pipeline = monadicIO $ do 82 | (msgs :: [ByteString]) <- pick arbitrary 83 | pre $ not (null msgs) 84 | res <- run $ do 85 | push <- socket Push 86 | _ <- bind push "inproc://pipeline" 87 | pull1 <- socket Pull 88 | pull2 <- socket Pull 89 | _ <- connect pull1 "inproc://pipeline" 90 | _ <- connect pull2 "inproc://pipeline" 91 | threadDelay 1000 92 | r <- mapM (testSockets push pull1 pull2) msgs 93 | close push 94 | close pull1 95 | close pull2 96 | threadDelay 1000 97 | return r 98 | assert $ and res 99 | where 100 | testSockets push pull1 pull2 msg = do 101 | send push msg 102 | send push msg 103 | send push msg 104 | threadDelay 1000 105 | a <- recv' pull1 106 | b <- recv' pull1 107 | c <- recv' pull1 108 | d <- recv' pull2 109 | e <- recv' pull2 110 | f <- recv' pull2 111 | let xs = catMaybes [a, b, c, d, e, f] 112 | return $ all (== msg) xs && (length xs == 3) 113 | 114 | -- test Req and Rep sockets 115 | prop_ReqRep :: Property 116 | prop_ReqRep = monadicIO $ do 117 | (msgs :: [ByteString]) <- pick arbitrary 118 | pre $ not (null msgs) 119 | res <- run $ do 120 | req <- socket Req 121 | _ <- bind req "inproc://reqrep" 122 | rep <- socket Rep 123 | _ <- connect rep "inproc://reqrep" 124 | threadDelay 1000 125 | r <- mapM (\m -> send req m >> recv rep >>= send rep >> recv req >>= return . (== m)) msgs 126 | close req 127 | close rep 128 | threadDelay 1000 129 | return r 130 | assert $ and res 131 | 132 | -- test Bus socket 133 | prop_Bus :: Property 134 | prop_Bus = monadicIO $ do 135 | (msgs :: [ByteString]) <- pick arbitrary 136 | pre $ not (null msgs) 137 | res <- run $ do 138 | -- Probably not how you're supposed to connect Bus nodes.. 139 | b1 <- socket Bus 140 | _ <- bind b1 "inproc://bus1" 141 | b2 <- socket Bus 142 | _ <- connect b2 "inproc://bus1" 143 | _ <- bind b2 "inproc://bus2" 144 | b3 <- socket Bus 145 | _ <- connect b3 "inproc://bus2" 146 | _ <- bind b3 "inproc://bus3" 147 | _ <- connect b1 "inproc://bus3" 148 | threadDelay 1000 149 | r <- mapM (testSockets b1 b2 b3) msgs 150 | close b1 151 | close b2 152 | close b3 153 | threadDelay 1000 154 | return r 155 | assert $ and res 156 | where 157 | testSockets b1 b2 b3 msg = do 158 | send b1 msg 159 | a <- recv b2 160 | b <- recv b3 161 | send b2 msg 162 | c <- recv b1 163 | d <- recv b3 164 | send b3 msg 165 | e <- recv b1 166 | f <- recv b2 167 | return $ all (== msg) [a, b, c, d, e, f] 168 | 169 | prop_TestOptions :: Property 170 | prop_TestOptions = monadicIO $ do 171 | res <- run $ do 172 | req <- socket Req 173 | _ <- bind req "tcp://*:5560" 174 | surveyor <- socket Surveyor 175 | _ <- bind surveyor "inproc://surveyor" 176 | threadDelay 1000 177 | setTcpNoDelay req 1 178 | v1 <- tcpNoDelay req 179 | setTcpNoDelay req 0 180 | v2 <- tcpNoDelay req 181 | setRequestResendInterval req 30000 182 | v3 <- requestResendInterval req 183 | setIpv4Only req 0 184 | v4 <- ipv4Only req 185 | setIpv4Only req 1 186 | v5 <- ipv4Only req 187 | setSndPrio req 7 188 | v6 <- sndPrio req 189 | setReconnectInterval req 50 190 | v7 <- reconnectInterval req 191 | setReconnectIntervalMax req 400 192 | v8 <- reconnectIntervalMax req 193 | setRcvBuf req 200000 194 | v9 <- rcvBuf req 195 | setSndBuf req 150000 196 | v10 <- sndBuf req 197 | setLinger req 500 198 | v11 <- linger req 199 | setSurveyorDeadline surveyor 2000 200 | v12 <- surveyorDeadline surveyor 201 | close req 202 | close surveyor 203 | threadDelay 1000 204 | return [v1 == 1, v2 == 0, v3 == 30000, v4 == 0, v5 == 1, v6 == 7, 205 | v7 == 50, v8 == 400, v9 == 200000, v10 == 150000, v11 == 500, v12 == 2000] 206 | assert $ and res 207 | --------------------------------------------------------------------------------