diff --git a/changes.md b/changes.md --- a/changes.md +++ b/changes.md @@ -1,8 +1,29 @@ +0.1.0.10 + + * Added hear primitive as one-shot counterpart to call. While handle + may be generally useful for many applications as it fully encapsulates repeated + handling of incoming requests, hear adds the ability to wait for a single + incoming request. Hear also returns a function of type Reply suitable for sending + a single response to the caller. Being more low-level in nature, some applications + find direct use of hear more flexible than the higher-level handle construct. + + * Fixed a mistake in 0.1.0.9 where RPCs where supposed to have unique identifiers + for matching up a call with a response. The value was never computed, when it + should have been a random value for every call, so that responses could be matched + with their originating request. Now using Data.UUID.V4 to generate unique identifiers + for each request; dependency added in cabal. + + * Unit tests on OS X 10.9 unreliable again, with both ghc 7.6.3 and ghc 7.8.1 (rc1) + + * Unit tests passing on Ubuntu 12.04 LTS AMD64 ghc 7.6.3 + + * Unit tests passing on FP Complete with 7.8 preview compiler + 0.1.0.9 * Added HelloWorld example, and updated code sample in documentation to reflect working with the current API - + * Early implementation of synchronous RPCs on top of endpoints, with basic unit tests. Both single and group RPCs are implemented, as are calls with definite and indefinite waits for responses. @@ -10,7 +31,7 @@ * Removed dependency on network-simple * Improved documentation throughout. - + 0.1.0.8 * Enabled selective out of order mesage reception, by using a Mailbox, an extension of STM's diff --git a/courier.cabal b/courier.cabal --- a/courier.cabal +++ b/courier.cabal @@ -1,5 +1,5 @@ name: courier -version: 0.1.0.9 +version: 0.1.0.10 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, @@ -64,7 +64,8 @@ hslogger, network, stm, - text + text, + uuid Test-Suite test-courier type: exitcode-stdio-1.0 diff --git a/src/Network/RPC.hs b/src/Network/RPC.hs --- a/src/Network/RPC.hs +++ b/src/Network/RPC.hs @@ -42,6 +42,10 @@ gcall, gcallWithTimeout, + hear, + hearTimeout, + Reply, + HandleSite, handle, hangup @@ -62,14 +66,19 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Serialize +import Data.UUID +import Data.UUID.V4 +import Data.Word -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- type Method = String +type RequestId = (Word32, Word32, Word32, Word32) + data Request a = (Serialize a) => Request { - requestId :: String, + requestId :: RequestId, requestCaller :: Name, requestMethod :: Method, requestArgs :: a @@ -89,7 +98,7 @@ return $ Request rid caller method args data Response b = (Serialize b) => Response { - responseId :: String, + responseId :: RequestId, responseFrom :: Name, responseValue :: b } @@ -126,7 +135,8 @@ -} call :: (Serialize a, Serialize b) => CallSite -> Name -> Method -> a -> IO b call (CallSite endpoint from) name method args = do - let req = Request {requestId = "",requestCaller = from,requestMethod = method, requestArgs = args} + ruuid <- nextRandom + let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args} sendMessage_ endpoint name $ encode req selectMessage endpoint $ \msg -> do case decode msg of @@ -160,7 +170,8 @@ -} gcall :: (Serialize a, Serialize b) => CallSite -> [Name] -> Method -> a -> IO (M.Map Name b) gcall (CallSite endpoint from) names method args = do - let req = Request {requestId = "",requestCaller = from,requestMethod = method, requestArgs = args} + ruuid <- nextRandom + let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args} sendAll req recvAll req M.empty where @@ -194,7 +205,8 @@ -} gcallWithTimeout :: (Serialize a, Serialize b) => CallSite -> [Name] -> Method -> Int -> a -> IO (M.Map Name (Maybe b)) gcallWithTimeout (CallSite endpoint from) names method delay args = do - let req = Request {requestId = "",requestCaller = from,requestMethod = method, requestArgs = args} + ruuid <- nextRandom + let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args} sendAll req allResults <- atomically $ newTVar M.empty responses <- race (recvAll req allResults) (threadDelay delay) @@ -232,6 +244,58 @@ complete partial = foldl (\final name -> M.insert name (M.lookup name partial) final) M.empty names {-| +A 'Reply' is a one-shot function for sending a response to an incoming request. +-} +type Reply b = b -> IO () + +{-| +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 +the reply. A good pattern for using 'hear' will pattern match the result to a tuple of +the form @(args,reply)@, then use the args as needed to compute a result, and then +finally send the result back to the client by simply passing the result to reply: @reply result@. + +The invoker of 'hear' must supply the 'Name' they have bound to the 'Endpoint', as this +helps the original requestor of the RPC differentiate responses when the RPC was a group +call. +-} +hear :: (Serialize a,Serialize b) => Endpoint -> Name -> Method -> IO (a,Reply b) +hear endpoint name method = do + (caller,rid,args) <- selectMessage endpoint $ \msg -> do + case decode msg of + Left _ -> Nothing + Right (Request rid caller rmethod args) -> do + if rmethod == method + then Just (caller,rid,args) + else Nothing + return (args, reply caller rid) + where + 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 +method arguments and a 'Reply' function useful for sending the reply. +-} +hearTimeout :: (Serialize a,Serialize b) => Endpoint -> Name -> Method -> Int -> IO (Maybe (a,Reply b)) +hearTimeout endpoint name method timeout = do + req <- selectMessageTimeout endpoint timeout $ \msg -> do + case decode msg of + Left _ -> Nothing + Right (Request rid caller rmethod args) -> do + if rmethod == method + then Just (caller,rid,args) + else Nothing + case req of + Just (caller,rid,args) -> return $ Just (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. -} @@ -247,15 +311,9 @@ return $ HandleSite name task where handleCall = do - (caller,rid,args) <- selectMessage endpoint $ \msg -> do - case decode msg of - Left _ -> Nothing - Right (Request rid caller rmethod args) -> do - if rmethod == method - then Just (caller,rid,args) - else Nothing + (args,reply) <- hear endpoint name method result <- fn args - sendMessage_ endpoint caller $ encode $ Response rid name result + reply result handleCall {-|