never executed always true always false
1 {-# LANGUAGE StrictData #-}
2
3 -- | Abstractions for the definition of
4 -- 'Command' 'Messages', that flow between
5 module UnliftIO.MessageBox.Command
6 ( Message (..),
7 Command,
8 ReturnType (..),
9 ReplyBox (),
10 CommandError (..),
11 DuplicateReply (..),
12 cast,
13 call,
14 replyTo,
15 callAsync,
16 delegateCall,
17 AsyncReply (),
18 waitForReply,
19 tryTakeReply,
20 )
21 where
22
23 import Control.Applicative (Alternative ((<|>)))
24 import Control.Monad (unless)
25 import Control.Monad.Reader (MonadReader)
26 import Data.Kind (Type)
27 import UnliftIO.MessageBox.Util.CallId
28 ( CallId (),
29 HasCallIdCounter,
30 )
31 import qualified UnliftIO.MessageBox.Util.CallId as CallId
32 import qualified UnliftIO.MessageBox.Class as MessageBox
33 import UnliftIO
34 ( Exception,
35 MonadUnliftIO,
36 TMVar,
37 Typeable,
38 atomically,
39 checkSTM,
40 newEmptyTMVarIO,
41 readTMVar,
42 readTVar,
43 registerDelay,
44 takeTMVar,
45 throwIO,
46 tryPutTMVar,
47 tryReadTMVar,
48 )
49
50 -- | This family allows to encode imperative /commands/.
51 --
52 -- The clauses of a 'Command' define the commands that
53 -- a process should execute.
54 --
55 -- Every clause may specify an individual 'ReturnType' that
56 -- declares if and what response is valid for a message.
57 --
58 -- For example:
59 --
60 -- >
61 -- > type LampId = Int
62 -- >
63 -- > data instance Command LightControl r where
64 -- > GetLamps :: Command LigthControl (Return [LampId])
65 -- > SwitchOn :: LampId -> Command LigthControl FireAndForget
66 -- >
67 -- > data LightControl -- the phantom type
68 -- >
69 --
70 -- The type index of the Command family is the uninhabited
71 -- @LightControl@ type.
72 -- .
73 --
74 -- The second type parameter indicates if a message requires the
75 -- receiver to send a reply back to the blocked and waiting
76 -- sender, or if no reply is necessary.
77 data family Command apiTag :: ReturnType -> Type
78
79 -- | Indicates if a 'Command' requires the
80 -- receiver to send a reply or not.
81 data ReturnType where
82 -- | Indicates that a 'Command' value is sent _one-way_.
83 --
84 -- Values of a 'Command' instance with 'FireAndForget' as second
85 -- parameter indicate that the sender should not expect any direct
86 -- answer from the recepient.
87 FireAndForget :: ReturnType
88 -- | Indicates that a 'Command' value requires the receiver
89 -- to send a reply of the given type.
90 --
91 -- Values of a 'Command' instance with 'Return' as second parameter
92 -- are received wrapped into a 'Blocking'.
93 Return :: Type -> ReturnType
94
95 -- | A message valid for some user defined @apiTag@.
96 --
97 -- The @apiTag@ tag (phantom-) type defines the
98 -- messages allowed here, declared by the instance of
99 -- 'Command' for 'apiTag'.
100 data Message apiTag where
101 -- | Wraps a 'Command' with a 'ReturnType' of 'Return' @result@.
102 --
103 -- Such a message can formed by using 'call'.
104 --
105 -- A 'Blocking' contains a 'ReplyBox' that can be
106 -- used to send the reply to the other process
107 -- blocking on 'call'
108 Blocking ::
109 Show (Command apiTag ( 'Return result)) =>
110 Command apiTag ( 'Return result) ->
111 ReplyBox result ->
112 Message apiTag
113 -- | If the 'Command' has a 'ReturnType' of 'FireAndForget'
114 -- it has fire-and-forget semantics.
115 --
116 -- The smart constructor 'cast' can be used to
117 -- this message.
118 NonBlocking ::
119 (Show (Command apiTag 'FireAndForget)) =>
120 Command apiTag 'FireAndForget ->
121 Message apiTag
122
123 instance Show (Message apiTag) where
124 showsPrec d (NonBlocking !m) =
125 showParen (d >= 9) (showString "NB: " . showsPrec 9 m)
126 showsPrec d (Blocking !m (MkReplyBox _ !callId)) =
127 showParen (d >= 9) (showString "B: " . showsPrec 9 m . showChar ' ' . shows callId)
128
129 -- | This is like 'Input', it can be used
130 -- by the receiver of a 'Blocking'
131 -- to either send a reply using 'reply'
132 -- or to fail/abort the request using 'sendRequestError'
133 data ReplyBox a
134 = MkReplyBox
135 !(TMVar (InternalReply a))
136 !CallId
137
138 -- | This is the reply to a 'Blocking' sent through the 'ReplyBox'.
139 type InternalReply a = (Either CommandError a)
140
141 -- | The failures that the receiver of a 'Return' 'Command', i.e. a 'Blocking',
142 -- can communicate to the /caller/, in order to indicate that
143 -- processing a request did not or will not lead to the result the
144 -- caller is blocked waiting for.
145 data CommandError where
146 -- | Failed to enqueue a 'Blocking' 'Command' 'Message' into the corresponding
147 -- 'MessageBox.Input'
148 CouldNotEnqueueCommand :: !CallId -> CommandError
149 -- | The request has failed /for reasons/.
150 BlockingCommandFailure :: !CallId -> CommandError
151 -- | Timeout waiting for the result.
152 BlockingCommandTimedOut :: !CallId -> CommandError
153 deriving stock (Show, Eq)
154
155 -- | Enqueue a 'NonBlocking' 'Message' into an 'Input'.
156 -- This is just for symetry to 'call', this is
157 -- equivalent to: @\input -> MessageBox.tryToDeliver input . NonBlocking@
158 --
159 -- The
160 {-# INLINE cast #-}
161 cast ::
162 ( MonadUnliftIO m,
163 MessageBox.IsInput o,
164 Show (Command apiTag 'FireAndForget)
165 ) =>
166 o (Message apiTag) ->
167 Command apiTag 'FireAndForget ->
168 m Bool
169 cast input !msg =
170 MessageBox.deliver input (NonBlocking msg)
171
172 -- | Enqueue a 'Blocking' 'Message' into an 'MessageBox.IsInput' and wait for the
173 -- response.
174 --
175 -- If message 'deliver'y failed, return @Left 'CouldNotEnqueueCommand'@.
176 --
177 -- If no reply was given by the receiving process (using 'replyTo') within
178 -- a given duration, return @Left 'BlockingCommandTimedOut'@.
179 --
180 -- Important: The given timeout starts __after__ 'deliver' has returned,
181 -- if 'deliver' blocks and delays, 'call' might take longer than the
182 -- specified timeout.
183 --
184 -- The receiving process can either delegate the call using
185 -- 'delegateCall' or reply to the call by using: 'replyTo'.
186 call ::
187 ( HasCallIdCounter env,
188 MonadReader env m,
189 MonadUnliftIO m,
190 MessageBox.IsInput input,
191 Show (Command apiTag ( 'Return result))
192 ) =>
193 input (Message apiTag) ->
194 Command apiTag ( 'Return result) ->
195 Int ->
196 m (Either CommandError result)
197 call !input !pdu !timeoutMicroseconds = do
198 !callId <- CallId.takeNext
199 !resultVar <- newEmptyTMVarIO
200 !sendSuccessful <- do
201 let !rbox = MkReplyBox resultVar callId
202 let !msg = Blocking pdu rbox
203 MessageBox.deliver input msg
204 if not sendSuccessful
205 then return (Left (CouldNotEnqueueCommand callId))
206 else do
207 timedOutVar <- registerDelay timeoutMicroseconds
208 atomically $
209 takeTMVar resultVar
210 <|> ( do
211 readTVar timedOutVar >>= checkSTM
212 return (Left (BlockingCommandTimedOut callId))
213 )
214
215 -- | This is called from the callback contained in the 'Blocking' 'Message'.
216 --
217 -- When handling a 'Blocking' 'Message' the 'ReplyBox' contained
218 -- in the message contains the 'TMVar' for the result, and this
219 -- function puts the result into it.
220 {-# INLINE replyTo #-}
221 replyTo :: (MonadUnliftIO m) => ReplyBox a -> a -> m ()
222 replyTo (MkReplyBox !replyBox !callId) !message =
223 atomically (tryPutTMVar replyBox (Right message))
224 >>= \success -> unless success (throwIO (DuplicateReply callId))
225
226 -- | Exception thrown by 'replyTo' when 'replyTo' is call more than once.
227 newtype DuplicateReply = DuplicateReply CallId deriving stock (Eq)
228
229 instance Show DuplicateReply where
230 showsPrec d (DuplicateReply !callId) =
231 showParen (d >= 9) (showString "more than one reply sent for: " . shows callId)
232
233 instance Exception DuplicateReply
234
235 -- | Pass on the call to another process.
236 --
237 -- Used to implement dispatcher processes.
238 --
239 -- Returns 'True' if the 'MessageBox.deliver' operation was
240 -- successful.
241 {-# INLINE delegateCall #-}
242 delegateCall ::
243 ( MonadUnliftIO m,
244 MessageBox.IsInput o,
245 Show (Command apiTag ( 'Return r))
246 ) =>
247 o (Message apiTag) ->
248 Command apiTag ( 'Return r) ->
249 ReplyBox r ->
250 m Bool
251 delegateCall !o !c !r =
252 MessageBox.deliver o (Blocking c r)
253
254 -- ** Non-Blocking call API
255
256 -- | Enqueue a 'Blocking' 'Message' into an 'MessageBox.IsInput'.
257 --
258 -- If the call to 'deliver' fails, return @Nothing@ otherwise
259 -- @Just@ the 'AsyncReply'.
260 --
261 -- The receiving process must use 'replyTo' with the 'ReplyBox'
262 -- received along side the 'Command' in the 'Blocking'.
263 callAsync ::
264 ( HasCallIdCounter env,
265 MonadReader env m,
266 MonadUnliftIO m,
267 MessageBox.IsInput o,
268 Show (Command apiTag ( 'Return result))
269 ) =>
270 o (Message apiTag) ->
271 Command apiTag ( 'Return result) ->
272 m (Maybe (AsyncReply result))
273 callAsync !input !pdu = do
274 !callId <- CallId.takeNext
275 !resultVar <- newEmptyTMVarIO
276 !sendSuccessful <- do
277 let !rbox = MkReplyBox resultVar callId
278 let !msg = Blocking pdu rbox
279 MessageBox.deliver input msg
280 if sendSuccessful
281 then return (Just (MkAsyncReply callId resultVar))
282 else return Nothing
283
284 -- | The result of 'callAsync'.
285 -- Use 'waitForReply' or 'tryTakeReply'.
286 data AsyncReply r
287 = MkAsyncReply !CallId !(TMVar (InternalReply r))
288
289 instance (Typeable r) => Show (AsyncReply r) where
290 showsPrec !d (MkAsyncReply !cId _) =
291 showParen (d >= 9) (showString "AR: " . shows cId)
292
293 -- | Wait for the reply of a 'Blocking' 'Message'
294 -- sent by 'callAsync'.
295 {-# INLINE waitForReply #-}
296 waitForReply ::
297 MonadUnliftIO m =>
298 -- | The time in micro seconds to wait
299 -- before returning 'Left' 'BlockingCommandTimedOut'
300 Int ->
301 AsyncReply result ->
302 m (Either CommandError result)
303 waitForReply !t (MkAsyncReply !cId !rVar) = do
304 !delay <- registerDelay t
305 atomically
306 ( ( do
307 !hasTimedOut <- readTVar delay
308 checkSTM hasTimedOut
309 return (Left (BlockingCommandTimedOut cId))
310 )
311 <|> readTMVar rVar
312 )
313
314 -- | If a reply for an 'callAsync' operation is available
315 -- return it, otherwise return 'Nothing'.
316 {-# INLINE tryTakeReply #-}
317 tryTakeReply ::
318 MonadUnliftIO m =>
319 AsyncReply result ->
320 m (Maybe (Either CommandError result))
321 tryTakeReply (MkAsyncReply _expectedCallId !resultVar) = do
322 !maybeTheResult <- atomically (tryReadTMVar resultVar)
323 case maybeTheResult of
324 Nothing ->
325 return Nothing
326 Just !result ->
327 return (Just result)