summaryrefslogtreecommitdiff
path: root/src/Network/QueryResponse.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/QueryResponse.hs')
-rw-r--r--src/Network/QueryResponse.hs46
1 files changed, 43 insertions, 3 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 4e110ec3..0fbbc929 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -134,6 +134,35 @@ partitionTransportM parse encodex tr = do
134 } 134 }
135 return (xtr, ytr) 135 return (xtr, ytr)
136 136
137partitionAndForkTransport ::
138 (dst -> msg -> IO ())
139 -> ((b,a) -> IO (Either (x,xaddr) (b,a)))
140 -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a))))
141 -> Transport err a b
142 -> IO (Transport err xaddr x, Transport err a b)
143partitionAndForkTransport forkedSend parse encodex tr = do
144 mvar <- newEmptyMVar
145 let xtr = tr { awaitMessage = \kont -> fix $ \again -> do
146 awaitMessage tr $ \m -> case m of
147 Just (Right msg) -> parse msg >>=
148 either (kont . Just . Right)
149 (\y -> putMVar mvar y >> again)
150 Just (Left e) -> kont $ Just (Left e)
151 Nothing -> kont Nothing
152 , sendMessage = \addr' msg' -> do
153 msg_addr <- encodex (msg',addr')
154 case msg_addr of
155 Just (Right (b,a)) -> sendMessage tr a b
156 Just (Left (msg,dst)) -> forkedSend dst msg
157 Nothing -> return ()
158 }
159 ytr = Transport
160 { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right
161 , sendMessage = sendMessage tr
162 , closeTransport = return ()
163 }
164 return (xtr, ytr)
165
137-- | 166-- |
138-- * f add x --> Nothing, consume x 167-- * f add x --> Nothing, consume x
139-- --> Just id, leave x to a different handler 168-- --> Just id, leave x to a different handler
@@ -376,16 +405,27 @@ transactionMethods ::
376 TableMethods t tid -- ^ Table methods to lookup values by /tid/. 405 TableMethods t tid -- ^ Table methods to lookup values by /tid/.
377 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. 406 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
378 -> TransactionMethods (g,t (MVar x)) tid addr x 407 -> TransactionMethods (g,t (MVar x)) tid addr x
379transactionMethods (TableMethods insert delete lookup) generate = TransactionMethods 408transactionMethods methods generate = transactionMethods' id tryPutMVar methods generate
409
410-- | Like 'transactionMethods' but allows extra information to be stored in the
411-- table of pending transactions. This also enables multiple 'Client's to
412-- share a single transaction table.
413transactionMethods' ::
414 (MVar x -> a) -- ^ store MVar into table entry
415 -> (a -> x -> IO void) -- ^ load MVar from table entry
416 -> TableMethods t tid -- ^ Table methods to lookup values by /tid/.
417 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
418 -> TransactionMethods (g,t a) tid addr x
419transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
380 { dispatchCancel = \tid (g,t) -> return (g, delete tid t) 420 { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
381 , dispatchRegister = \v _ (g,t) -> 421 , dispatchRegister = \v _ (g,t) ->
382 let (tid,g') = generate g 422 let (tid,g') = generate g
383 t' = insert tid v t 423 t' = insert tid (store v) t
384 in return ( tid, (g',t') ) 424 in return ( tid, (g',t') )
385 , dispatchResponse = \tid x (g,t) -> 425 , dispatchResponse = \tid x (g,t) ->
386 case lookup tid t of 426 case lookup tid t of
387 Just v -> let t' = delete tid t 427 Just v -> let t' = delete tid t
388 in return ((g,t'),void $ tryPutMVar v x) 428 in return ((g,t'),void $ load v x)
389 Nothing -> return ((g,t), return ()) 429 Nothing -> return ((g,t), return ())
390 } 430 }
391 431