packages feed

zeromq4-simple (empty) → 0.0.0

raw patch · 6 files changed

+362/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, constraints, hashable, uuid, zeromq4-haskell

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for zeromq4-simple++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Athan Clark (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Athan Clark nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# zeromq4-simple
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/System/ZMQ4/Simple.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE+    MultiParamTypeClasses+  , FunctionalDependencies+  , GeneralizedNewtypeDeriving+  , DeriveGeneric+  , TupleSections+  , OverloadedStrings+  , DataKinds+  , KindSignatures+  , TypeFamilies+  , ConstraintKinds+  , UndecidableInstances+  #-}++module System.ZMQ4.Simple where++import System.ZMQ4.Monadic+  ( ZMQ, SocketType+  , Req (..), Rep (..), Dealer (..), Router (..)+  , Pub (..), Sub (..), XPub (..), XSub (..)+  , Pull (..), Push (..), Pair (..))+import qualified System.ZMQ4.Monadic as Z++import Data.Restricted (toRestricted)+import Data.Hashable (Hashable)+import Data.ByteString (ByteString)+import qualified Data.UUID as UUID+import Data.UUID.V4 (nextRandom)+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (NonEmpty (..))+import Data.Constraint (Constraint)+import Data.Aeson (FromJSON (..), ToJSON (..), encode, decode)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)++import GHC.Generics (Generic)+import GHC.TypeLits (TypeError, ErrorMessage (..))++++-- * Types++data Ordinal = Ord1 | OrdN++-- | The numerity of `from`+type family Ordinance from to (loc :: Location) :: Ordinal where+  Ordinance Pair Pair     'Bound     = 'Ord1+  Ordinance Pair Pair     'Connected = 'Ord1+  Ordinance Pub Sub       'Bound     = 'Ord1+  Ordinance XPub Sub      'Bound     = 'Ord1+  Ordinance Sub Pub       'Connected = 'OrdN+  Ordinance Sub XPub      'Connected = 'OrdN+  Ordinance Pub XSub      'Connected = 'OrdN+  Ordinance XSub Pub      'Bound     = 'Ord1+  Ordinance Req Rep       'Connected = 'Ord1+  Ordinance Rep Req       'Bound     = 'Ord1+  Ordinance Req Router    'Connected = 'OrdN+  Ordinance Router Req    'Bound     = 'Ord1+  Ordinance Rep Dealer    'Connected = 'OrdN+  Ordinance Dealer Rep    'Bound     = 'Ord1+  Ordinance Dealer Router 'Connected = 'OrdN+  Ordinance Dealer Router 'Bound     = 'Ord1+  Ordinance Router Dealer 'Connected = 'OrdN+  Ordinance Router Dealer 'Bound     = 'Ord1+  Ordinance Pull Push     'Connected = 'OrdN+  Ordinance Pull Push     'Bound     = 'Ord1+  Ordinance Push Pull     'Connected = 'OrdN+  Ordinance Push Pull     'Bound     = 'Ord1+++type family NeedsIdentity from to :: Constraint where+  NeedsIdentity Req Router = ()+  NeedsIdentity Dealer Rep = ()+  NeedsIdentity Dealer Router = ()+++data Location = Connected | Bound++type family Bindable from :: Constraint where+  Bindable Pair = ()+  Bindable Rep = ()+  Bindable Router = ()+  Bindable Dealer = ()+  Bindable Pub = ()+  Bindable XPub = ()+  Bindable XSub = ()+  Bindable Pull = ()+  Bindable Push = ()++type family Connectable from :: Constraint where+  Connectable Pair = ()+  Connectable Req = ()+  Connectable Rep = ()+  Connectable Router = ()+  Connectable Dealer = ()+  Connectable Sub = ()+  Connectable Pub = ()+  Connectable XSub = ()+  Connectable XPub = ()+  Connectable Pull = ()+  Connectable Push = ()+++newtype Socket z from to (loc :: Location)+  = Socket {getSocket :: Z.Socket z from}+++type family IsLegal from to :: Constraint where+  IsLegal Pair Pair = ()+  IsLegal Sub Pub = ()+  IsLegal Pub Sub = ()+  IsLegal XSub Pub = TypeError (Text "Not legal ZeroMQ socket: For some reason xsub/pub isn't working")+  IsLegal XPub Sub = ()+  IsLegal Pub XSub = TypeError (Text "Not legal ZeroMQ socket: For some reason pub/xsub isn't working")+  IsLegal Sub XPub = ()+  IsLegal XPub XSub = ()+  IsLegal XSub XPub = ()+  IsLegal Push Pull = ()+  IsLegal Pull Push = ()+  IsLegal Req Rep = ()+  IsLegal Rep Req = ()+  IsLegal Req Router = ()+  IsLegal Router Req = ()+  IsLegal Rep Dealer = ()+  IsLegal Dealer Rep = ()+  IsLegal Router Dealer = ()+  IsLegal Dealer Router = ()+  IsLegal Router Router = ()+  IsLegal Dealer Dealer = ()+  IsLegal from to = TypeError (Text "Not legal ZeroMQ socket")+++socket :: SocketType from+       => IsLegal from to+       => from -> to -> ZMQ z (Socket z from to loc)+socket from _ = Socket <$> Z.socket from++bind :: Bindable from => Socket z from to 'Bound -> String -> ZMQ z ()+bind (Socket s) x = Z.bind s x++connect :: Connectable from => Socket z from to 'Connected -> String -> ZMQ z ()+connect (Socket s) x = Z.connect s x+++newtype ZMQIdent = ZMQIdent {getZMQIdent :: ByteString}+  deriving (Show, Eq, Ord, Generic, Hashable)++newUUIDIdentity :: IO ZMQIdent+newUUIDIdentity =+  (ZMQIdent . LBS.toStrict . UUID.toByteString) <$> nextRandom+++setIdentity :: NeedsIdentity from to+            => Socket z from to loc+            -> ZMQIdent -> ZMQ z Bool+setIdentity (Socket s) (ZMQIdent clientId) =+  case toRestricted clientId of+    Nothing -> pure False+    Just ident -> True <$ Z.setIdentity ident s+++setUUIDIdentity :: NeedsIdentity from to => Socket z from to loc -> ZMQ z ()+setUUIDIdentity s = do+  ident <- liftIO newUUIDIdentity+  worked <- setIdentity s ident+  when (not worked) (error "couldn't restrict uuid")+++-- * Classes++-- | Send a message over a ZMQ socket+class Sendable from to aux+  | from to -> aux where+  send :: aux -> Socket z from to loc -> NonEmpty ByteString -> ZMQ z ()++sendJson :: Sendable from to aux => ToJSON a => aux -> Socket z from to loc -> a -> ZMQ z ()+sendJson a s x = send a s (LBS.toStrict (encode x) :| [])++instance Sendable Pub Sub () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable XPub Sub () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Pub XSub () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Req Rep () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Rep Req () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Req Router () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Router Req ZMQIdent where+  send (ZMQIdent addr) (Socket s) (x:|xs) = Z.sendMulti s (addr :| "":x:xs)++instance Sendable Rep Dealer () where+  send () (Socket s) xs = Z.sendMulti s xs++instance Sendable Dealer Rep () where+  send () (Socket s) (x:|xs) = Z.sendMulti s ("" :| x:xs)++instance Sendable Dealer Router () where+  send () (Socket s) (x:|xs) = Z.sendMulti s ("" :| x:xs)++instance Sendable Router Dealer ZMQIdent where+  send (ZMQIdent addr) (Socket s) (x:|xs) = Z.sendMulti s (addr :| "":x:xs)+++-- | Receive a message over a ZMQ socket+class Receivable from to aux+  | from to -> aux where+  receive :: Socket z from to loc -> ZMQ z (Maybe (aux, NonEmpty ByteString))++receiveJson :: Receivable from to aux => FromJSON a => Socket z from to loc -> ZMQ z (Maybe (aux, a))+receiveJson s = do+  mX <- receive s+  case mX of+    Nothing -> pure Nothing+    Just (aux, msg :| _) -> case decode (LBS.fromStrict msg) of+      Nothing -> pure Nothing+      Just x -> pure (Just (aux,x))++instance Receivable Sub Pub () where+  receive (Socket s) = receiveBasic s++instance Receivable Sub XPub () where+  receive (Socket s) = receiveBasic s++instance Receivable XSub Pub () where+  receive (Socket s) = receiveBasic s++instance Receivable Req Rep () where+  receive (Socket s) = receiveBasic s++instance Receivable Rep Req () where+  receive (Socket s) = receiveBasic s++instance Receivable Req Router () where+  receive (Socket s) = receiveBasic s++instance Receivable Router Req ZMQIdent where+  receive (Socket s) = do+    xs <- Z.receiveMulti s+    case xs of+      (addr:_:x:xs') -> pure (Just (ZMQIdent addr, x :| xs'))+      _ -> pure Nothing++instance Receivable Rep Dealer () where+  receive (Socket s) = receiveBasic s++instance Receivable Dealer Rep () where+  receive (Socket s) = do+    xs <- Z.receiveMulti s+    case xs of+      (_:x:xs') -> pure (Just ((), x :| xs'))+      _ -> pure Nothing++instance Receivable Dealer Router () where+  receive (Socket s) = do+    xs <- Z.receiveMulti s+    case xs of+      (_:x:xs') -> pure (Just ((), x :| xs'))+      _ -> pure Nothing++instance Receivable Router Dealer ZMQIdent where+  receive (Socket s) = do+    xs <- Z.receiveMulti s+    case xs of+      (addr:_:x:xs') -> pure (Just (ZMQIdent addr, x :| xs'))+      _ -> pure Nothing+++receiveBasic :: Z.Receiver t => Z.Socket s t -> ZMQ s (Maybe ((), NonEmpty ByteString))+receiveBasic s = do+  xs <- Z.receiveMulti s+  case xs of+    (x:xs') -> pure (Just ((), x :| xs'))+    _ -> pure Nothing
+ zeromq4-simple.cabal view
@@ -0,0 +1,44 @@+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2a99200b850346f7f72e5b0ab742314015655ab8d06c5ac016a0bfd2e031a2f9++name:           zeromq4-simple+version:        0.0.0+synopsis:       More constrained extensions to zeromq4-haskell+description:    Please see the README on GitHub at <https://github.com/githubuser/zeromq4-simple#readme>+category:       System, FFI+author:         Athan Clark+maintainer:     athan.clark@localcooking.com+copyright:      2018 (c) Local Cooking Inc.+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: git://git.localcooking.com/tooling/zeromq4-simple++library+  exposed-modules:+      System.ZMQ4.Simple+  other-modules:+      Paths_zeromq4_simple+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , constraints+    , hashable+    , uuid+    , zeromq4-haskell+  default-language: Haskell2010