courier 0.1.1.2 → 0.1.1.3

raw patch · 6 files changed

+70/−47 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changes.md +8/−1
• courier.cabal +3/−7
• src/Network/Endpoints.hs +5/−5
• src/Network/Transport.hs +12/−12
• src/Network/Transport/Memory.hs +29/−9
• tests/TransportTestSuite.hs +13/−13

@@ -1,8 +1,15 @@+0.1.1.3++  * Changed with... functions to return specified types in IO, instead of always returning (); not technically a+    breaking change, but does prevent backward compatibility from here+  * Memory transport flushes to destinations before completing shutdown+  * Linting and first compile against GHC 8.0.1; continuing to support back to 7.6 for now+ 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,6 +1,7 @@ name:                courier-version:             0.1.1.2-synopsis:           A message-passing library for simplifying network applications+version:             0.1.1.3+synopsis:            A message-passing library for simplifying network applications+tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1 description:         Inspired by Erlang's simple message-passing facilities, courier provides roughly similar                      capabilities. Applications simply create one or more endpoints,                      bind each to a transport using a given name, then can freely@@ -64,10 +65,6 @@    ghc-options:     -Wall-    -fno-state-hack-    -threaded-    -- -O2-    -- -fprof-auto    -- other-modules: @@ -87,7 +84,6 @@   main-is: EchoServer.hs   ghc-options:     -Wall-    -fno-state-hack     -threaded   build-depends:       base >=4.6 && <5,                        cereal,

@@ -183,7 +183,7 @@ without requiring the client also have a 'Network.Transport.Binding'.  -}-withName :: Endpoint -> Name -> IO () -> IO ()+withName :: Endpoint -> Name -> IO a -> IO a withName endpoint origin actor = do   atomically $ bindName endpoint origin   finally actor $ atomically $ unbindName endpoint origin@@ -204,10 +204,10 @@ if the 'Endpoint' is not bound to the 'Name'. -} unbindName :: Endpoint -> Name -> STM ()-unbindName endpoint name = modifyTVar (boundEndpointNames endpoint) $ \bindings -> do-  case S.member name bindings of-    False -> throw $ BindingDoesNotExist name-    True -> S.delete name bindings+unbindName endpoint name = modifyTVar (boundEndpointNames endpoint) $ \bindings ->+  if S.member name bindings+    then S.delete name bindings+    else throw $ BindingDoesNotExist name  {-| Exceptions generated when `Network.Transport.bind`ing a 'Name'.

@@ -175,7 +175,7 @@ {-| Within the body of the function, ensures that 'Message's are dispatched as necessary. -}-withTransport :: IO Transport -> (Transport -> IO ()) -> IO ()+withTransport :: IO Transport -> (Transport -> IO a) -> IO a withTransport factory fn = do   transport <- factory   finally (fn transport)@@ -185,7 +185,7 @@ Within the body of the function, ensure that there is a 'Dispatcher' for the 'Endpoint'.  -}-withEndpoint :: Transport -> Endpoint -> IO ()  -> IO ()+withEndpoint :: Transport -> Endpoint -> IO a  -> IO a withEndpoint transport endpoint fn = do   d <- dispatch transport endpoint   finally fn@@ -205,7 +205,7 @@ on the provided 'Transport' during a function.  -}-withBinding :: Transport -> Endpoint -> Name -> IO () -> IO ()+withBinding :: Transport -> Endpoint -> Name -> IO a -> IO a withBinding transport endpoint name actor = do   atomically $ do     bindings <- readTVar $ boundEndpointNames endpoint@@ -221,7 +221,7 @@ A helper for ensuring there are 'Binding's of a specific 'Endpoint' to specific 'Name's on the provided 'Transport' during a function. -}-withBinding2 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> IO () -> IO ()+withBinding2 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> IO a -> IO a withBinding2 transport (endpoint1,name1) (endpoint2,name2) fn =   withBinding transport endpoint1 name1 $     withBinding transport endpoint2 name2 fn@@ -230,7 +230,7 @@ A helper for ensuring there are 'Binding's of a specific 'Endpoint' to specific 'Name's on the provided 'Transport' during a function. -}-withBinding3 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> IO () -> IO ()+withBinding3 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> IO a -> IO a withBinding3 transport (endpoint1,name1) (endpoint2,name2) (endpoint3,name3) fn =   withBinding transport endpoint1 name1 $     withBinding transport endpoint2 name2 $@@ -240,7 +240,7 @@ A helper for ensuring there are 'Binding's of a specific 'Endpoint' to specific 'Name's on the provided 'Transport' during a function. -}-withBinding4 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> IO () -> IO ()+withBinding4 :: Transport -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> (Endpoint,Name) -> IO a -> IO a withBinding4 transport (endpoint1,name1) (endpoint2,name2) (endpoint3,name3) (endpoint4,name4) fn =   withBinding transport endpoint1 name1 $     withBinding transport endpoint2 name2 $@@ -258,7 +258,7 @@ {-| A helper for ensuring that a 'Connection' is maintained during execution of a function. -}-withConnection :: Transport -> Endpoint -> Name -> IO () -> IO ()+withConnection :: Transport -> Endpoint -> Name -> IO a -> IO a withConnection transport endpoint name fn = do   connection <- connect transport endpoint name   finally fn $ disconnect connection@@ -266,25 +266,25 @@ {-| 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 -> Name -> Name -> IO a -> IO a 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 -> Name -> Name -> Name -> IO a -> IO a 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 -> Name -> Name -> Name -> Name -> IO a -> IO a withConnection4 transport endpoint name1 name2 name3 name4 = withConnections transport endpoint [name1,name2,name3,name4]  -- --  Various helpers ---withConnections :: Transport -> Endpoint -> [Name] -> IO () -> IO ()+withConnections :: Transport -> Endpoint -> [Name] -> IO a -> IO a withConnections _ _ [] fn = fn withConnections transport endpoint (destination:destinations) fn =   withConnection transport endpoint destination $@@ -294,7 +294,7 @@ 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 :: Transport -> [Name] -> Endpoint -> Name -> IO a -> IO a withCompleteNetwork _ [] _ _ fn = fn withCompleteNetwork transport(destination:destinations) endpoint origin fn =   if destination == origin

@@ -55,23 +55,29 @@       shutdown = return ()       } -memoryDispatcher :: Bindings -> Endpoint -> IO Dispatcher+memoryDispatcher :: TBindings -> Endpoint -> IO Dispatcher memoryDispatcher vBindings endpoint = do   d <- async disp   return Dispatcher {-    stop = cancel d+    stop = do+      cancel d+      memoryFlushMessages vBindings endpoint   }   where     disp = do       atomically $ do         bindings <- readTVar vBindings         env <- readMailbox $ endpointOutbound endpoint-        case M.lookup (messageDestination env) bindings  of-          Nothing -> return ()-          Just destination -> postMessage destination (envelopeMessage env)+        memoryDispatchEnvelope bindings env       disp -memoryBind :: Bindings -> Endpoint -> Name -> IO Binding+memoryDispatchEnvelope :: Bindings -> Envelope -> STM ()+memoryDispatchEnvelope bindings env =+  case M.lookup (messageDestination env) bindings  of+    Nothing -> return ()+    Just destination -> postMessage destination (envelopeMessage env)++memoryBind :: TBindings -> Endpoint -> Name -> IO Binding memoryBind vBindings endpoint name = atomically $ do   bindings <- readTVar vBindings   case M.lookup name bindings of@@ -83,14 +89,28 @@       }     Just _ -> throw $ BindingExists name -memoryUnbind :: Bindings -> Endpoint -> Name -> IO ()-memoryUnbind vBindings _ name = atomically $ do+memoryUnbind :: TBindings -> Endpoint -> Name -> IO ()+memoryUnbind vBindings _ name = atomically $   modifyTVar vBindings $ M.delete name -type Bindings = TVar (M.Map Name Endpoint)+type TBindings = TVar Bindings+type Bindings = M.Map Name Endpoint  memoryConnect :: Endpoint -> Name -> IO Connection memoryConnect _ _ =   return Connection {     disconnect = return ()   }++memoryFlushMessages :: TBindings -> Endpoint -> IO ()+memoryFlushMessages vBindings endpoint =+  atomically $ flush+  where+    flush = do+      bindings <- readTVar vBindings+      maybeEnv <- tryReadMailbox $ endpointOutbound endpoint+      case maybeEnv of+        Just env -> do+          memoryDispatchEnvelope bindings env+          flush+        Nothing -> return ()

@@ -67,7 +67,7 @@   ]  timeLimited :: Assertion -> Assertion-timeLimited assn = timeBound (1 * 1000000 :: Int) assn+timeLimited assn = timeBound (2 * 1000000 :: Int) assn  testTransportEndpointSendReceive :: IO Transport -> Name -> Name -> Assertion testTransportEndpointSendReceive transportFactory name1 name2 = timeLimited $ do@@ -135,15 +135,15 @@   withTransport transportFactory $ \transport ->     withNewEndpoint2 transport $ \endpoint1 endpoint2 ->       withBinding2 transport (endpoint1,name1) (endpoint2,name2) $ do-        withConnection transport endpoint1 name2 $ do-          _ <- async $ do+        withConnection transport endpoint1 name2 $+          withAsync (do               (bytes,reply) <- hear endpoint2 name2 "foo"               let Right msg = decode bytes-              reply $ encode $ msg ++ "!"-          let cs = newCallSite endpoint1 name1-          bytes <- call cs name2 "foo" $ encode "hello"-          let Right result = decode bytes-          assertEqual "Result not expected value" "hello!" result+              reply $ encode $ msg ++ "!") $ \_ -> do+            let cs = newCallSite endpoint1 name1+            bytes <- call cs name2 "foo" $ encode "hello"+            let Right result = decode bytes+            assertEqual "Result not expected value" "hello!" result  testTransportOneCallHear :: IO Transport -> Name -> Name -> Assertion testTransportOneCallHear transportFactory name1 name2 = timeLimited $ do@@ -155,13 +155,13 @@             withConnection transport endpoint1 name2 $ do               let cs = newCallSite endpoint1 name1               acall <- async $ call cs name2 "foo" $ encode "hello"-              _ <- async $ do+              withAsync (do                   (bytes,reply) <- hear endpoint2 name2 "foo"                   let Right msg = decode bytes-                  reply $ encode $ msg ++ "!"-              bytes <- wait acall-              let Right result = decode bytes-              assertEqual "Result not expected value" "hello!" result+                  reply $ encode $ msg ++ "!") $ \_ -> do+                bytes <- wait acall+                let Right result = decode bytes+                assertEqual "Result not expected value" "hello!" result  testTransportConcurrentCallHear :: IO Transport -> Name -> Name -> Assertion testTransportConcurrentCallHear transportFactory name1 name2 = timeLimited $ do