-
Notifications
You must be signed in to change notification settings - Fork 0
/
CallbackServer.hs
194 lines (171 loc) · 5.4 KB
/
CallbackServer.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
{-# LANGUAGE UndecidableInstances #-}
-- | Build a "Control.Eff.Concurrent.EffectfulServer" from callbacks.
--
-- This module contains in instance of 'E.Server' that delegates to
-- callback functions.
--
-- @since 0.27.0
module Control.Eff.Concurrent.Protocol.CallbackServer
( start,
startLink,
Server,
ServerId (..),
Event (..),
TangibleCallbacks,
Callbacks,
callbacks,
onEvent,
CallbacksEff,
callbacksEff,
onEventEff,
)
where
import Control.DeepSeq
import Control.Eff
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Protocol
import Control.Eff.Concurrent.Protocol.EffectfulServer (Event (..))
import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as E
import Control.Eff.Extend ()
import Control.Eff.Log
import Data.Coerce
import Data.Kind
import Data.Proxy
import Data.String
import qualified Data.Text as T
import Data.Typeable
-- | Execute the server loop, that dispatches incoming events
-- to either a set of 'Callbacks' or 'CallbacksEff'.
--
-- @since 0.29.1
start ::
forall (tag :: Type) eLoop q e.
( TangibleCallbacks tag eLoop q,
E.Server (Server tag eLoop q) (Processes q),
FilteredLogging (Processes q),
HasProcesses e q
) =>
CallbacksEff tag eLoop q ->
Eff e (Endpoint tag)
start = E.start
-- | Execute the server loop, that dispatches incoming events
-- to either a set of 'Callbacks' or 'CallbacksEff'.
--
-- @since 0.29.1
startLink ::
forall (tag :: Type) eLoop q e.
( TangibleCallbacks tag eLoop q,
E.Server (Server tag eLoop q) (Processes q),
FilteredLogging (Processes q),
HasProcesses e q
) =>
CallbacksEff tag eLoop q ->
Eff e (Endpoint tag)
startLink = E.startLink
-- | Phantom type to indicate a callback based 'E.Server' instance.
--
-- @since 0.27.0
data Server tag eLoop e deriving (Typeable)
instance ToTypeLogMsg tag => ToTypeLogMsg (Server tag eLoop e) where
toTypeLogMsg _ = toTypeLogMsg (Proxy @tag)
-- | The constraints for a /tangible/ 'Server' instance.
--
-- @since 0.27.0
type TangibleCallbacks tag eLoop e =
( HasProcesses eLoop e,
ToTypeLogMsg tag,
Typeable e,
Typeable eLoop,
Typeable tag
)
-- | The name/id of a 'Server' for logging purposes.
--
-- @since 0.24.0
newtype ServerId (tag :: Type) = MkServerId {_fromServerId :: T.Text}
deriving (Typeable, NFData, Ord, Eq, IsString)
instance ToTypeLogMsg tag => ToTypeLogMsg (ServerId tag) where
toTypeLogMsg _ = toTypeLogMsg (Proxy @tag) <> packLogMsg "_server_id"
instance ToLogMsg (ServerId tag) where
toLogMsg x = coerce x
instance (ToTypeLogMsg tag) => Show (ServerId tag) where
showsPrec d px@(MkServerId x) =
showParen
(d >= 10)
( showString (T.unpack x)
. showString "_"
. shows (toTypeLogMsg px)
)
instance (ToLogMsg (E.Init (Server tag eLoop e)), TangibleCallbacks tag eLoop e) => E.Server (Server (tag :: Type) eLoop e) (Processes e) where
type ServerPdu (Server tag eLoop e) = tag
type ServerEffects (Server tag eLoop e) (Processes e) = eLoop
data Init (Server tag eLoop e) = MkServer
{ genServerId :: ServerId tag,
genServerRunEffects :: forall x. (Endpoint tag -> Eff eLoop x -> Eff (Processes e) x),
genServerOnEvent :: Endpoint tag -> Event tag -> Eff eLoop ()
}
deriving (Typeable)
runEffects myEp svr = genServerRunEffects svr myEp
onEvent myEp svr = genServerOnEvent svr myEp
instance forall (tag :: Type) (e1 :: [Type -> Type]) (e2 :: [Type -> Type]). ToLogMsg (E.Init (Server tag e1 e2)) where
toLogMsg x = toLogMsg (genServerId x)
instance (TangibleCallbacks tag eLoop e) => NFData (E.Init (Server (tag :: Type) eLoop e)) where
rnf (MkServer x y z) = rnf x `seq` y `seq` z `seq` ()
instance forall tag eLoop e. (TangibleCallbacks tag eLoop e) => Show (E.Init (Server (tag :: Type) eLoop e)) where
showsPrec d svr =
showParen
(d >= 10)
( showsPrec 11 (genServerId svr)
. showChar ' '
. shows (toTypeLogMsg (Proxy @tag))
. showString " callback-server"
)
-- ** Smart Constructors for 'Callbacks'
-- | A convenience type alias for callbacks that do not
-- need a custom effect.
--
-- @since 0.29.1
type Callbacks tag e = CallbacksEff tag (Processes e) e
-- | A smart constructor for 'Callbacks'.
--
-- @since 0.29.1
callbacks ::
forall tag q.
(Endpoint tag -> Event tag -> Eff (Processes q) ()) ->
ServerId tag ->
Callbacks tag q
callbacks evtCb i = callbacksEff (const id) evtCb i
-- | A simple smart constructor for 'Callbacks'.
--
-- @since 0.29.1
onEvent ::
forall tag q.
(Event tag -> Eff (Processes q) ()) ->
ServerId (tag :: Type) ->
Callbacks tag q
onEvent = onEventEff id
-- ** Smart Constructors for 'CallbacksEff'
-- | A convenience type alias for __effectful__ callback based 'E.Server' instances.
--
-- See 'Callbacks'.
--
-- @since 0.29.1
type CallbacksEff tag eLoop e = E.Init (Server tag eLoop e)
-- | A smart constructor for 'CallbacksEff'.
--
-- @since 0.29.1
callbacksEff ::
forall tag eLoop q.
(forall x. Endpoint tag -> Eff eLoop x -> Eff (Processes q) x) ->
(Endpoint tag -> Event tag -> Eff eLoop ()) ->
ServerId tag ->
CallbacksEff tag eLoop q
callbacksEff a b c = MkServer c a b
-- | A simple smart constructor for 'CallbacksEff'.
--
-- @since 0.29.1
onEventEff ::
(forall a. Eff eLoop a -> Eff (Processes q) a) ->
(Event tag -> Eff eLoop ()) ->
ServerId (tag :: Type) ->
CallbacksEff tag eLoop q
onEventEff h f i = callbacksEff (const h) (const f) i