/
Client.purs
181 lines (157 loc) · 6.98 KB
/
Client.purs
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
module Type.Trout.Client
( class HasClients
, getClients
, class HasMethodClients
, getMethodClients
, asClients
) where
import Prelude
import Affjax (Request, defaultRequest, request)
import Affjax.ResponseFormat (json, string) as AXResponseFormat
import Affjax.ResponseFormat (printResponseFormatError)
import Control.Monad.Except.Trans (throwError)
import Data.Argonaut (class DecodeJson, decodeJson)
import Data.Array (singleton)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.HTTP.Method as Method
import Data.Maybe (Maybe)
import Data.String (joinWith)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Tuple (Tuple(..))
import Effect.Aff (Aff)
import Effect.Exception (error)
import Prim.Row (class Cons)
import Type.Proxy (Proxy(..))
import Type.Trout (type (:<|>), type (:=), type (:>), Capture, CaptureAll, Lit, Method, QueryParam, QueryParams, Resource)
import Type.Trout.ContentType.HTML (HTML)
import Type.Trout.ContentType.JSON (JSON)
import Type.Trout.PathPiece (class ToPathPiece, toPathPiece)
import Type.Trout.Record as Record
type RequestBuilder = { path :: Array String, params :: Array (Tuple String String) }
emptyRequestBuilder :: RequestBuilder
emptyRequestBuilder = { path: [], params: [] }
appendSegment :: String -> RequestBuilder -> RequestBuilder
appendSegment segment req =
req { path = req.path <> singleton segment }
appendQueryParam :: String -> String -> RequestBuilder -> RequestBuilder
appendQueryParam param value req =
req { params = req.params <> singleton (Tuple param value) }
toAffjaxRequest :: RequestBuilder -> Request Unit
toAffjaxRequest req = defaultRequest { url = "/" <> joinWith "/" req.path <> params }
where
params = case req.params of
[] -> ""
segments -> "?" <> joinWith "&" (map (\(Tuple q x) -> q <> "=" <> x) segments)
class HasClients r mk | r -> mk where
getClients :: Proxy r -> RequestBuilder -> mk
instance hasClientsAlt :: ( HasClients c1 mk1
, HasClients c2 (Record mk2)
, IsSymbol name
, Cons name mk1 mk2 out
)
=> HasClients (name := c1 :<|> c2) (Record out) where
getClients _ req = Record.insert name first rest
where
name = SProxy :: SProxy name
first = getClients (Proxy :: Proxy c1) req
rest = getClients (Proxy :: Proxy c2) req
instance hasClientsNamed :: ( HasClients c mk
, IsSymbol name
, Cons name mk () out
)
=> HasClients (name := c) (Record out) where
getClients _ req = Record.insert name clients {}
where
name = SProxy :: SProxy name
clients = getClients (Proxy :: Proxy c) req
instance hasClientsLit :: (HasClients sub subMk, IsSymbol lit)
=> HasClients (Lit lit :> sub) subMk where
getClients _ req =
getClients (Proxy :: Proxy sub) (appendSegment segment req)
where
segment = reflectSymbol (SProxy :: SProxy lit)
instance hasClientsCapture :: (HasClients sub subMk, IsSymbol c, ToPathPiece t)
=> HasClients (Capture c t :> sub) (t -> subMk) where
getClients _ req x =
getClients (Proxy :: Proxy sub) (appendSegment (toPathPiece x) req)
instance hasClientsCaptureAll :: (HasClients sub subMk, IsSymbol c, ToPathPiece t)
=> HasClients (CaptureAll c t :> sub) (Array t -> subMk) where
getClients _ req xs =
getClients (Proxy :: Proxy sub) (foldl (flip appendSegment) req (map toPathPiece xs))
instance hasClientsQueryParam :: (HasClients sub subMk, IsSymbol c, ToPathPiece t)
=> HasClients (QueryParam c t :> sub) (Maybe t -> subMk) where
getClients _ req x =
getClients (Proxy :: Proxy sub) (foldl (flip $ appendQueryParam q) req (map toPathPiece x))
where
q = reflectSymbol (SProxy :: SProxy c)
instance hasClientsQueryParams :: (HasClients sub subMk, IsSymbol c, ToPathPiece t)
=> HasClients (QueryParams c t :> sub) (Array t -> subMk) where
getClients _ req x =
getClients (Proxy :: Proxy sub) (foldl (flip $ appendQueryParam q) req (map toPathPiece x))
where
q = reflectSymbol (SProxy :: SProxy c)
instance hasClientsResource :: (HasClients methods clients)
=> HasClients (Resource methods) clients where
getClients _ req =
getClients (Proxy :: Proxy methods) req
instance hasClientsMethodAlt :: ( IsSymbol method
, HasMethodClients method repr cts mk1
, HasClients methods (Record mk2)
, Cons method mk1 mk2 out
)
=> HasClients
(Method method repr cts :<|> methods)
(Record out) where
getClients _ req =
Record.insert method first rest
where
method = SProxy :: SProxy method
cts = Proxy :: Proxy cts
first = getMethodClients method cts req
rest = getClients (Proxy :: Proxy methods) req
instance hasClientsMethod :: ( IsSymbol method
, HasMethodClients method repr cts mk1
, Cons method mk1 () out
)
=> HasClients (Method method repr cts) (Record out) where
getClients _ req =
Record.insert method clients {}
where
method = SProxy :: SProxy method
cts = Proxy :: Proxy cts
clients = getMethodClients method cts req
toMethod :: forall m
. IsSymbol m
=> SProxy m
-> Either Method.Method Method.CustomMethod
toMethod p = Method.fromString (reflectSymbol p)
class HasMethodClients method repr cts client | cts -> repr, cts -> client where
getMethodClients :: SProxy method -> Proxy cts -> RequestBuilder -> client
instance hasMethodClientMethodJson
:: (DecodeJson r, IsSymbol method)
=> HasMethodClients method r JSON (Aff r) where
getMethodClients method _ req = do
r <- toAffjaxRequest req
# _ { method = toMethod method, responseFormat = AXResponseFormat.json }
# request
# map _.body
case r of
Left err -> throwError (error $ printResponseFormatError err)
Right json ->
case decodeJson json of
Left err -> throwError (error err)
Right x -> pure x
instance hasMethodClientsHTMLString
:: IsSymbol method
=> HasMethodClients method String HTML (Aff String) where
getMethodClients method _ req = do
r <- toAffjaxRequest req
# _ { method = toMethod method, responseFormat = AXResponseFormat.string }
# request
# map _.body
case r of
Left err -> throwError (error $ printResponseFormatError err)
Right x -> pure x
asClients :: forall r mk. HasClients r mk => Proxy r -> mk
asClients = flip getClients emptyRequestBuilder