diff options
author | joe <joe@jerkface.net> | 2017-09-20 21:08:34 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-09-20 21:08:34 -0400 |
commit | 11d2b22814b0d31935f4d7b67706d9ee72c310d3 (patch) | |
tree | f3ee7b69edead4420a959631952733d390b5f463 /src/Network/QueryResponse.hs | |
parent | 6b822e47e4995e4aaf4cb1cc034c34314bd51da2 (diff) |
Side-effecting variant of partitionTransport.
Diffstat (limited to 'src/Network/QueryResponse.hs')
-rw-r--r-- | src/Network/QueryResponse.hs | 23 |
1 files changed, 17 insertions, 6 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs index 41e25486..7244304e 100644 --- a/src/Network/QueryResponse.hs +++ b/src/Network/QueryResponse.hs | |||
@@ -78,23 +78,34 @@ partitionTransport :: ((b,a) -> Either (x,xaddr) (y,yaddr)) | |||
78 | -> ((y,yaddr) -> (b,a)) | 78 | -> ((y,yaddr) -> (b,a)) |
79 | -> Transport err a b | 79 | -> Transport err a b |
80 | -> IO (Transport err xaddr x, Transport err yaddr y) | 80 | -> IO (Transport err xaddr x, Transport err yaddr y) |
81 | partitionTransport parse encodex encodey tr = do | 81 | partitionTransport parse encodex encodey tr = |
82 | partitionTransportM (return . parse) (return . encodex) (return . encodey) tr | ||
83 | |||
84 | -- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar' | ||
85 | -- is used to share the same underlying socket, so be sure to fork a thread for | ||
86 | -- both returned 'Transport's to avoid hanging. | ||
87 | partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (y,yaddr))) | ||
88 | -> ((x,xaddr) -> IO (b,a)) | ||
89 | -> ((y,yaddr) -> IO (b,a)) | ||
90 | -> Transport err a b | ||
91 | -> IO (Transport err xaddr x, Transport err yaddr y) | ||
92 | partitionTransportM parse encodex encodey tr = do | ||
82 | mvar <- newEmptyMVar | 93 | mvar <- newEmptyMVar |
83 | let xtr = tr { awaitMessage = \kont -> fix $ \again -> do | 94 | let xtr = tr { awaitMessage = \kont -> fix $ \again -> do |
84 | awaitMessage tr $ \m -> case m of | 95 | awaitMessage tr $ \m -> case m of |
85 | Just (Right msg) -> either (kont . Just . Right) | 96 | Just (Right msg) -> parse msg >>= |
86 | (\y -> putMVar mvar y >> again) | 97 | either (kont . Just . Right) |
87 | $ parse msg | 98 | (\y -> putMVar mvar y >> again) |
88 | Just (Left e) -> kont $ Just (Left e) | 99 | Just (Left e) -> kont $ Just (Left e) |
89 | Nothing -> kont Nothing | 100 | Nothing -> kont Nothing |
90 | , sendMessage = \addr' msg' -> do | 101 | , sendMessage = \addr' msg' -> do |
91 | let (msg,addr) = encodex (msg',addr') | 102 | (msg,addr) <- encodex (msg',addr') |
92 | sendMessage tr addr msg | 103 | sendMessage tr addr msg |
93 | } | 104 | } |
94 | ytr = Transport | 105 | ytr = Transport |
95 | { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right | 106 | { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right |
96 | , sendMessage = \addr' msg' -> do | 107 | , sendMessage = \addr' msg' -> do |
97 | let (msg,addr) = encodey (msg',addr') | 108 | (msg,addr) <- encodey (msg',addr') |
98 | sendMessage tr addr msg | 109 | sendMessage tr addr msg |
99 | , closeTransport = return () | 110 | , closeTransport = return () |
100 | } | 111 | } |