diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Network/QueryResponse.hs | 19 |
1 files changed, 14 insertions, 5 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs index 29a221e8..c8a6fa80 100644 --- a/src/Network/QueryResponse.hs +++ b/src/Network/QueryResponse.hs | |||
@@ -124,18 +124,27 @@ data MethodHandler err tid addr x = forall a b. MethodHandler | |||
124 | -- address of the query is provided to the handler. | 124 | -- address of the query is provided to the handler. |
125 | , methodAction :: addr -> a -> IO b | 125 | , methodAction :: addr -> a -> IO b |
126 | } | 126 | } |
127 | | forall a. NoReply | ||
128 | { -- | Parse the query into a more specific type for this method. | ||
129 | methodParse :: x -> Either err a | ||
130 | -- | Fully typed action to perform upon the query. The remote origin | ||
131 | -- address of the query is provided to the handler. | ||
132 | , noreplyAction :: addr -> a -> IO () | ||
133 | } | ||
127 | 134 | ||
128 | -- | Attempt to invoke a 'MethodHandler' upon a given inbound query. If the | 135 | -- | Attempt to invoke a 'MethodHandler' upon a given inbound query. If the |
129 | -- parse is successful, the returned IO action will construct our reply. | 136 | -- parse is successful, the returned IO action will construct our reply if |
130 | -- Otherwise, a parse err is returned. | 137 | -- there is one. Otherwise, a parse err is returned. |
131 | dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke. | 138 | dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke. |
132 | -> tid -- ^ The transaction id for this query\/response session. | 139 | -> tid -- ^ The transaction id for this query\/response session. |
133 | -> addr -- ^ Our own address, to which the query was sent. | 140 | -> addr -- ^ Our own address, to which the query was sent. |
134 | -> x -- ^ The query packet. | 141 | -> x -- ^ The query packet. |
135 | -> addr -- ^ The origin address of the query. | 142 | -> addr -- ^ The origin address of the query. |
136 | -> Either err (IO x) | 143 | -> Either err (IO (Maybe x)) |
137 | dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr = | 144 | dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr = |
138 | fmap (\a -> wrapR tid self addr <$> f addr a) $ unwrapQ x | 145 | fmap (\a -> Just . wrapR tid self addr <$> f addr a) $ unwrapQ x |
146 | dispatchQuery (NoReply unwrapQ f) tid self x addr = | ||
147 | fmap (\a -> f addr a >> return Nothing) $ unwrapQ x | ||
139 | 148 | ||
140 | -- | These four parameters are required to implement an ougoing query. A | 149 | -- | These four parameters are required to implement an ougoing query. A |
141 | -- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that | 150 | -- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that |
@@ -365,7 +374,7 @@ handleMessage (Client net d err pending whoami responseID) again = do | |||
365 | self <- whoami (Just addr) | 374 | self <- whoami (Just addr) |
366 | tid' <- responseID tid | 375 | tid' <- responseID tid |
367 | either (reportParseError err) | 376 | either (reportParseError err) |
368 | (>>= sendMessage net addr) | 377 | (>>= mapM_ (sendMessage net addr)) |
369 | (dispatchQuery m tid' self plain addr) | 378 | (dispatchQuery m tid' self plain addr) |
370 | IsResponse tid -> do | 379 | IsResponse tid -> do |
371 | action <- atomically $ do | 380 | action <- atomically $ do |