courier 0.1.1.1 → 0.1.1.2

raw patch · 5 files changed

+90/−20 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changes.md +5/−0
• courier.cabal +1/−1
• src/Network/RPC.hs +52/−2
• src/Network/Transport.hs +26/−12
• src/Network/Transport/Sockets/TCP.hs +6/−5

@@ -1,3 +1,8 @@+0.1.1.2++  * Updated README with better working example+  * Removed warning about TCP/IP transport; it's working again+   0.1.1.1  There are significant changes in this release, due to a complete rewrite of TCP connection handling, and,

@@ -1,5 +1,5 @@ name:                courier-version:             0.1.1.1+version:             0.1.1.2 synopsis:           A message-passing library for simplifying network applications description:         Inspired by Erlang's simple message-passing facilities, courier provides roughly similar                      capabilities. Applications simply create one or more endpoints,

@@ -47,10 +47,13 @@     methodSelector,     hear,     hearTimeout,+    hearAll,+    hearAllTimeout,     Reply,      HandleSite,     handle,+    handleAll,     hangup,      Request(..),@@ -326,6 +329,12 @@                 then Just (caller,rid,args)                 else Nothing +anySelector :: Message -> Maybe (Name,RequestId,Method,Message)+anySelector msg =+  case decode msg of+    Left _ -> Nothing+    Right (Request rid caller method args) -> Just (caller,rid,method,args)+ {-| Wait for a single incoming request to invoke the indicated 'Method' on the specified 'Endpoint'. Return both the method arguments and a 'Reply' function useful for sending@@ -345,7 +354,6 @@         reply caller rid result = do             sendMessage endpoint caller $ encode $ Response rid name result - {-| Same as 'hear', except return 'Nothing' if no request received within the specified timeout (measured in microseconds), or return a 'Just' instance containing both the@@ -362,6 +370,34 @@             sendMessage endpoint caller $ encode $ Response rid name result  {-|+A variant of 'hear', except it listens for any incoming RPC request on the specified 'Endpoint'.+-}+hearAll :: Endpoint -> Name -> IO (Method,Message,Reply Message)+hearAll endpoint name = do+    (caller,rid,method,args) <- selectMessage endpoint anySelector+    return (method,args,reply caller rid)+    where+        reply caller rid result =+          sendMessage endpoint caller $ encode $ Response rid name result+        anySelector msg =+          case decode msg of+            Left _ -> Nothing+            Right (Request rid caller method args) -> Just (caller,rid,method,args)++{-|+A variant of 'hearTimeout', except it listens for any incoming RPC request on the specified 'Endpoint'+-}+hearAllTimeout :: Endpoint -> Name -> Int -> IO (Maybe (Method,Message,Reply Message))+hearAllTimeout endpoint name timeout = do+    req <- selectMessageTimeout endpoint timeout anySelector+    case req of+        Just (caller,rid,method,args) -> return $ Just (method,args, reply caller rid)+        Nothing -> return Nothing+    where+        reply caller rid result = do+            sendMessage endpoint caller $ encode $ Response rid name result++{-| A 'HandleSite' is a just reference to the actual handler of a specific method. Mostly for invoking 'hangup' on the handler, once it is no longer needed. -}@@ -373,12 +409,26 @@ -} handle :: Endpoint -> Name -> Method -> (Message -> IO Message) -> IO HandleSite handle endpoint name method fn = do-    task <- async $ handleCall+    task <- async handleCall     return $ HandleSite name task     where         handleCall = do             (args,reply) <- hear endpoint name method             result <- fn args+            reply result+            handleCall++{-|+Handle all RPCs on the specified 'Endpoint' until 'hangup' is called on the returned 'HandleSite'+-}+handleAll :: Endpoint -> Name -> (Method -> Message -> IO Message) -> IO HandleSite+handleAll endpoint name fn = do+    task <- async handleCall+    return $ HandleSite name task+    where+        handleCall = do+            (method,args,reply) <- hearAll endpoint name+            result <- fn method args             reply result             handleCall 

@@ -69,6 +69,9 @@   withConnection3,   withConnection4, +  withConnections,+  withCompleteNetwork+ ) where  -- local imports@@ -264,25 +267,36 @@ A helper for ensuring that 2 'Connection's are maintained during execution of a function. -} withConnection2 :: Transport -> Endpoint -> Name -> Name -> IO () -> IO ()-withConnection2 transport endpoint name1 name2 fn =-  withConnection transport endpoint name1 $-    withConnection transport endpoint name2 fn+withConnection2 transport endpoint name1 name2 = withConnections transport endpoint [name1,name2]  {-| A helper for ensuring that 3 'Connection's are maintained during execution of a function. -} withConnection3 :: Transport -> Endpoint -> Name -> Name -> Name -> IO () -> IO ()-withConnection3 transport endpoint name1 name2 name3 fn =-  withConnection transport endpoint name1 $-    withConnection transport endpoint name2 $-      withConnection transport endpoint name3 fn+withConnection3 transport endpoint name1 name2 name3 = withConnections transport endpoint [name1,name2,name3]  {-| A helper for ensuring that 4 'Connection's are maintained during execution of a function. -} withConnection4 :: Transport -> Endpoint -> Name -> Name -> Name -> Name -> IO () -> IO ()-withConnection4 transport endpoint name1 name2 name3 name4 fn =-  withConnection transport endpoint name1 $-    withConnection transport endpoint name2 $-      withConnection transport endpoint name3 $-        withConnection transport endpoint name4 fn+withConnection4 transport endpoint name1 name2 name3 name4 = withConnections transport endpoint [name1,name2,name3,name4]++--+--  Various helpers+--+withConnections :: Transport -> Endpoint -> [Name] -> IO () -> IO ()+withConnections _ _ [] fn = fn+withConnections transport endpoint (destination:destinations) fn =+  withConnection transport endpoint destination $+    withConnections transport endpoint destinations fn++{-|+This is a helper designed to create a complete network, where there are+enough connections to ensure every endpoint has a connection to every other endpoint.+-}+withCompleteNetwork :: Transport -> [Name] -> Endpoint -> Name -> IO () -> IO ()+withCompleteNetwork _ [] _ _ fn = fn+withCompleteNetwork transport(destination:destinations) endpoint origin fn =+  if destination == origin+    then withConnections transport endpoint destinations fn+    else withCompleteNetwork transport destinations endpoint origin fn

@@ -51,7 +51,7 @@   vPeers <- newTVar M.empty   mailboxes <- newTVar M.empty   return Transport {-    bind = tcpBind mailboxes family resolver,+    bind = tcpBind mailboxes family resolver vPeers,     dispatch = dispatcher mailboxes,     connect =  socketConnect mailboxes $ tcpConnect family resolver,     shutdown = tcpShutdown vPeers@@ -81,9 +81,8 @@ tcpSocketResolver6 :: Name -> IO [NS.SockAddr] tcpSocketResolver6 = socketResolver6 NS.Stream -tcpBind :: Mailboxes -> NS.Family -> Resolver -> Endpoint -> Name -> IO Binding-tcpBind mailboxes family resolver endpoint name = do-  vConnections <- atomically $ newTVar M.empty+tcpBind :: Mailboxes -> NS.Family -> Resolver -> SocketConnections -> Endpoint -> Name -> IO Binding+tcpBind mailboxes family resolver vConnections endpoint name = do   listener <- async $ tcpListen mailboxes family resolver vConnections endpoint name   return Binding {     bindingName = name,@@ -102,7 +101,9 @@   connection <- tcpConnection peer   msngr <- async $ messenger mailboxes endpoint connection   let conn = Connection {-    disconnect = cancel msngr+    disconnect = do+      atomically $ modifyTVar vConnections $ M.delete peerAddress+      cancel msngr   }   maybeOldConn <- atomically $ do     connections <- readTVar vConnections