-
Notifications
You must be signed in to change notification settings - Fork 9
/
Module.hs
170 lines (148 loc) · 7.84 KB
/
Module.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
{-# LANGUAGE UndecidableInstances #-}
module Tendermint.SDK.Application.Module
( Module(..)
, Component
, ModuleEffs
, ModuleList(..)
, Application(..)
, ToApplication(..)
, hoistApplication
, Eval(..)
, makeApplication
, applyAnteHandler
) where
import Data.Kind (Type)
import Data.Proxy
import GHC.TypeLits (ErrorMessage (..), Symbol,
TypeError)
import qualified Network.ABCI.Types.Messages.Request as Req
import Polysemy (EffectRow, Members, Sem)
import Servant.API ((:<|>) (..), (:>))
import Tendermint.SDK.BaseApp ((:&), BaseAppEffs,
BaseEffs)
import Tendermint.SDK.BaseApp.Block
import qualified Tendermint.SDK.BaseApp.Query as Q
import Tendermint.SDK.BaseApp.Store (Scope (..))
import qualified Tendermint.SDK.BaseApp.Transaction as T
-- import qualified Network.ABCI.Types.Messages.Response as Resp
type Component = EffectRow -> Type
-- NOTE: This does not pull in transitive dependencies on purpose to avoid
-- unintended enlarged scope
type family DependencyEffs (ms :: [Component]) :: EffectRow where
DependencyEffs '[] = '[]
DependencyEffs (Module _ _ _ _ es deps ': rest) = es :& DependencyEffs rest
DependencyEffs _ = TypeError ('Text "DependencyEffs is a partial function defined only on partially applied Modules")
data Module (name :: Symbol) (check :: Type) (deliver :: Type) (query :: Type) (es :: EffectRow) (deps :: [Component]) (r :: EffectRow) = Module
{ moduleTxChecker :: T.RouteTx check r
, moduleTxDeliverer :: T.RouteTx deliver r
, moduleQuerier :: Q.RouteQ query r
, moduleEval :: forall s. (Members T.TxEffs s, Members BaseEffs s, Members (DependencyEffs deps) s) => forall a. Sem (es :& s) a -> Sem s a
}
type family ModuleEffs (m :: Component) :: EffectRow where
ModuleEffs (Module _ _ _ _ es deps) = es :& DependencyEffs deps :& T.TxEffs :& BaseEffs
ModuleEffs _ = TypeError ('Text "ModuleEffs is a partial function defined only on Component")
data ModuleList (ms :: [Component]) r where
NilModules :: ModuleList '[] r
(:+) :: Module name check deliver query es deps r
-> ModuleList ms r
-> ModuleList (Module name check deliver query es deps ': ms) r
infixr 5 :+
data Application check deliver query r s = Application
{ applicationTxChecker :: T.RouteTx check r
, applicationTxDeliverer :: T.RouteTx deliver r
, applicationQuerier :: Q.RouteQ query s
, applicationBeginBlocker :: Req.BeginBlock -> Sem r ()
, applicationEndBlocker :: Req.EndBlock -> Sem r EndBlockResult
}
class ToApplication ms r where
type ApplicationC ms :: Type
type ApplicationD ms :: Type
type ApplicationQ ms :: Type
toApplication :: ModuleList ms r -> Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) r r
instance ToApplication '[Module name check deliver query es deps] r where
type ApplicationC '[Module name check deliver query es deps] = name :> check
type ApplicationD '[Module name check deliver query es deps] = name :> deliver
type ApplicationQ '[Module name check deliver query es deps] = name :> query
toApplication (Module{..} :+ NilModules) =
Application
{ applicationTxChecker = moduleTxChecker
, applicationTxDeliverer = moduleTxDeliverer
, applicationQuerier = moduleQuerier
, applicationBeginBlocker = defaultBeginBlocker
, applicationEndBlocker = defaultEndBlocker
}
instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver query es deps ': m' ': ms) r where
type ApplicationC (Module name check deliver query es deps ': m' ': ms) = (name :> check) :<|> ApplicationC (m' ': ms)
type ApplicationD (Module name check deliver query es deps ': m' ': ms) = (name :> deliver) :<|> ApplicationD (m' ': ms)
type ApplicationQ (Module name check deliver query es deps ': m' ': ms) = (name :> query) :<|> ApplicationQ (m' ': ms)
toApplication (Module{..} :+ rest) =
let app = toApplication rest
in Application
{ applicationTxChecker = moduleTxChecker :<|> applicationTxChecker app
, applicationTxDeliverer = moduleTxDeliverer :<|> applicationTxDeliverer app
, applicationQuerier = moduleQuerier :<|> applicationQuerier app
, applicationBeginBlocker = defaultBeginBlocker
, applicationEndBlocker = defaultEndBlocker
}
hoistApplication
:: T.HasTxRouter check r 'QueryAndMempool
=> T.HasTxRouter deliver r 'Consensus
=> Q.HasQueryRouter query s
=> (forall a. Sem r a -> Sem r' a)
-> (forall a. Sem s a -> Sem s' a)
-> Application check deliver query r s
-> Application check deliver query r' s'
hoistApplication natT natQ (app :: Application check deliver query r s) =
Application
{ applicationTxChecker = T.hoistTxRouter (Proxy @check) (Proxy @r) (Proxy @'QueryAndMempool) natT $ applicationTxChecker app
, applicationTxDeliverer = T.hoistTxRouter (Proxy @deliver) (Proxy @r) (Proxy @'Consensus) natT $ applicationTxDeliverer app
, applicationQuerier = Q.hoistQueryRouter (Proxy @query) (Proxy @s) natQ $ applicationQuerier app
, applicationBeginBlocker = natT . applicationBeginBlocker app
, applicationEndBlocker = natT . applicationEndBlocker app
}
class Eval ms (core :: EffectRow) where
type Effs ms core :: EffectRow
eval
:: proxy core
-> ModuleList ms r
-> forall a.
Sem (Effs ms core) a
-> Sem (T.TxEffs :& BaseAppEffs core) a
instance (DependencyEffs deps ~ '[]) => Eval '[Module name check deliver query es deps] core where
type Effs '[Module name check deliver query es deps] core = es :& T.TxEffs :& BaseAppEffs core
eval _ (m :+ NilModules) = moduleEval m
instance ( Members (DependencyEffs deps) (Effs (m' ': ms) s)
, Members T.TxEffs (Effs (m' ': ms) s)
, Members BaseEffs (Effs (m' ': ms) s)
, Eval (m' ': ms) s
) => Eval (Module name check deliver query es deps ': m' ': ms) s where
type Effs (Module name check deliver query es deps ': m' ': ms) s = es :& (Effs (m': ms)) s
eval pcore (m :+ rest) = eval pcore rest . moduleEval m
makeApplication
:: Eval ms core
=> ToApplication ms (Effs ms core)
=> T.HasTxRouter (ApplicationC ms) (Effs ms core) 'QueryAndMempool
=> T.HasTxRouter (ApplicationD ms) (Effs ms core) 'Consensus
=> Q.HasQueryRouter (ApplicationQ ms) (Effs ms core)
=> Proxy core
-> T.AnteHandler (Effs ms core)
-> ModuleList ms (Effs ms core)
-> (Req.BeginBlock -> Sem (Effs ms core) ())
-> (Req.EndBlock -> Sem (Effs ms core) EndBlockResult)
-> Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (T.TxEffs :& BaseAppEffs core) (Q.QueryEffs :& BaseAppEffs core)
makeApplication p@(Proxy :: Proxy core) ah (ms :: ModuleList ms (Effs ms core)) beginBlocker endBlocker =
let app = applyAnteHandler ah $ toApplication ms :: Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (Effs ms core) (Effs ms core)
-- WEIRD: if you move the eval into a separate let binding then it doesn't typecheck...
in hoistApplication (eval @ms @core p ms) (T.evalReadOnly . eval @ms @core p ms) (app{applicationBeginBlocker = beginBlocker, applicationEndBlocker = endBlocker})
applyAnteHandler
:: T.HasTxRouter check r 'QueryAndMempool
=> T.HasTxRouter deliver r 'Consensus
=> T.AnteHandler r
-> Application check deliver query r s
-> Application check deliver query r s
applyAnteHandler ah (app :: Application check deliver query r s) =
app { applicationTxChecker = T.applyAnteHandler (Proxy @check) (Proxy @r) (Proxy @'QueryAndMempool) ah $
applicationTxChecker app
, applicationTxDeliverer = T.applyAnteHandler (Proxy @deliver) (Proxy @r) (Proxy @'Consensus) ah $
applicationTxDeliverer app
}