]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/API.hs
Rename stuffs and init client testing
[haskell/symantic-http.git] / Symantic / HTTP / API.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE DeriveFunctor #-}
4 {-# LANGUAGE StrictData #-}
5 {-# LANGUAGE TypeApplications #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE TypeOperators #-}
8 module Symantic.HTTP.API where
9
10 import Data.Bool
11 import Data.Eq (Eq(..))
12 import Data.Functor (Functor)
13 import Data.Kind (Constraint)
14 import Data.Ord (Ord(..))
15 import Data.Proxy (Proxy(..))
16 import Data.String (String)
17 import Prelude (and, pure)
18 import System.IO (IO)
19 import Text.Show (Show(..))
20 import qualified Data.ByteString as BS
21 import qualified Data.Text as T
22 import qualified Network.HTTP.Types as HTTP
23 import qualified Web.HttpApiData as Web
24
25 import Symantic.HTTP.Mime
26
27 -- * Class 'HTTP_API'
28 class
29 ( Cat repr
30 , Alt repr
31 -- , Pro repr
32 , HTTP_Version repr
33 , HTTP_Path repr
34 , HTTP_Header repr
35 , HTTP_Query repr
36 -- , HTTP_BasicAuth repr
37 , HTTP_Response repr
38 ) => HTTP_API (repr:: * -> * -> *)
39
40 -- * Class 'Cat'
41 class Cat repr where
42 (<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
43 -- (.>) :: repr x y -> repr a c -> repr a c; infixl 4 .>
44
45 -- * Class 'Alt'
46 class Alt repr where
47 {-
48 type AltMerge repr :: * -> * -> *
49 (<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
50 -}
51 (<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
52 -- try :: repr k k -> repr k k
53 -- option :: k -> repr k k -> repr k k
54
55 -- ** Type ':!:'
56 -- Like '(,)' but 'infixl'.
57 -- Used to get alternative commands from a 'Client'
58 -- or to supply alternative handlers to a 'Server'.
59 data (:!:) a b = a:!:b
60 infixl 3 :!:
61
62 -- * Class 'Pro'
63 -- | Mainly useful to write a combinator which is a specialization of another,
64 -- by calling it instead of rewriting its logic.
65 -- Because 'a' si asked by a 'Client' but given to a 'Server',
66 -- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
67 -- Hence the names 'Pro' and 'dimap'.
68 class Pro repr where
69 dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
70
71 -- * Type family 'HttpApiData'
72 -- | Either 'Web.ToHttpApiData' for a 'Client',
73 -- or 'Web.FromHttpApiData' for a 'Server'.
74 type family HttpApiData (repr:: * -> * -> *) :: * -> Constraint
75
76 -- * Class 'HTTP_Path'
77 class HTTP_Path repr where
78 segment :: Segment -> repr k k
79 capture' ::
80 HttpApiData repr a =>
81 Name -> repr (a -> k) k
82 captureAll :: repr ([Segment] -> k) k
83
84 -- | Convenient wrapper of 'segment'.
85 (</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
86 (</>) n = (segment n <.>); infixr 5 </>
87
88 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
89 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
90 capture ::
91 forall a k repr.
92 HTTP_Path repr =>
93 HttpApiData repr a =>
94 Name -> repr (a -> k) k
95 capture = capture'
96 {-# INLINE capture #-}
97
98 type Segment = T.Text
99 type Path = [Segment]
100 type Name = String
101
102 -- * Class 'HTTP_Header'
103 class HTTP_Header repr where
104 header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
105 type HeaderValue = BS.ByteString
106
107 -- * Class 'HTTP_Body'
108 class HTTP_Body repr where
109 type BodyArg repr :: * -> * -> *
110 body' ::
111 forall a mt k.
112 MimeUnserialize a mt =>
113 MimeSerialize a mt =>
114 repr (BodyArg repr mt a -> k) k
115
116 -- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
117 -- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
118 body ::
119 forall a mt k repr.
120 HTTP_Body repr =>
121 MimeUnserialize a mt =>
122 MimeSerialize a mt =>
123 repr (BodyArg repr mt a -> k) k
124 body = body' @repr
125 {-# INLINE body #-}
126
127 {-
128 data AcceptResponse repr a =
129 forall mt. MimeSerialize a mt =>
130 AcceptResponse (Proxy mt, repr a)
131 -}
132
133 -- * Class 'HTTP_Query'
134 class HTTP_Query repr where
135 queryParams' ::
136 HttpApiData repr a =>
137 QueryName -> repr ([a] -> k) k
138 queryFlag ::
139 HttpApiData repr Bool =>
140 QueryName -> repr (Bool -> k) k
141 default queryFlag ::
142 Pro repr =>
143 HttpApiData repr Bool =>
144 QueryName -> repr (Bool -> k) k
145 queryFlag n = dimap and pure (queryParams' n)
146 type QueryName = BS.ByteString
147 type QueryValue = BS.ByteString
148
149 queryParams ::
150 forall a k repr.
151 HTTP_Query repr =>
152 HttpApiData repr a =>
153 QueryName -> repr ([a] -> k) k
154 queryParams = queryParams'
155 {-# INLINE queryParams #-}
156
157 -- * Class 'HTTP_Auth'
158 -- | <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>
159 class HTTP_BasicAuth repr where
160 type BasicAuthable repr :: * -> * -> Constraint
161 basicAuth' ::
162 BasicAuthable repr context a =>
163 BasicAuthRealm -> context -> repr (a -> k) k
164
165 basicAuth ::
166 forall a context k repr.
167 HTTP_BasicAuth repr =>
168 BasicAuthable repr context a =>
169 BasicAuthRealm ->
170 context -> repr (a -> k) k
171 basicAuth = basicAuth' @repr @context @a
172 {-# INLINE basicAuth #-}
173
174 -- ** Type 'BasicAuth'
175 data BasicAuth usr
176 = BasicAuth_Authorized usr
177 | BasicAuth_BadPassword
178 | BasicAuth_NoSuchUser
179 | BasicAuth_Unauthorized
180 deriving (Eq, Show, Functor)
181
182 type BasicAuthRealm = BS.ByteString
183 type BasicAuthName = BS.ByteString
184 type BasicAuthPass = BS.ByteString
185
186 -- * Class 'HTTP_Version'
187 class HTTP_Version repr where
188 version :: HTTP.HttpVersion -> repr k k
189
190 -- * Class 'HTTP_Status'
191 class HTTP_Status repr where
192 status :: StatusIs -> repr (HTTP.Status -> k) k
193
194 -- ** Type 'StatusIs'
195 data StatusIs
196 = StatusIsInformational
197 | StatusIsSuccessful
198 | StatusIsRedirection
199 | StatusIsClientError
200 | StatusIsServerError
201 | StatusIs HTTP.Status
202 deriving (Eq, Ord, Show)
203 statusIs :: StatusIs -> (HTTP.Status -> Bool)
204 statusIs = \case
205 StatusIsInformational -> HTTP.statusIsInformational
206 StatusIsSuccessful -> HTTP.statusIsSuccessful
207 StatusIsRedirection -> HTTP.statusIsRedirection
208 StatusIsClientError -> HTTP.statusIsClientError
209 StatusIsServerError -> HTTP.statusIsServerError
210 StatusIs x -> \y -> HTTP.statusCode x == HTTP.statusCode y
211
212 -- * Class 'HTTP_Response'
213 class HTTP_Response repr where
214 type Response repr :: *
215 type ResponseArg repr :: * -> * -> *
216 response ::
217 MimeUnserialize a mt =>
218 MimeSerialize a mt =>
219 k ~ Response repr =>
220 HTTP.Method ->
221 repr (ResponseArg repr mt a -> k) k
222
223 -- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
224 -- and put the type variables 'a' then 'mt' first instead or 'repr'
225 -- so they can be passed using 'TypeApplications'
226 -- without adding a '@_' for 'repr'.
227 get,head,put,post,delete,trace,connect,options,patch ::
228 forall a mt k repr.
229 HTTP_Response repr =>
230 MimeUnserialize a mt =>
231 MimeSerialize a mt =>
232 k ~ Response repr =>
233 repr (ResponseArg repr mt a -> k) k
234 get = response HTTP.methodGet
235 head = response HTTP.methodHead
236 put = response HTTP.methodPut
237 post = response HTTP.methodPost
238 delete = response HTTP.methodDelete
239 trace = response HTTP.methodTrace
240 connect = response HTTP.methodConnect
241 options = response HTTP.methodOptions
242 patch = response HTTP.methodPatch
243 {-# INLINE get #-}
244 {-# INLINE head #-}
245 {-# INLINE put #-}
246 {-# INLINE post #-}
247 {-# INLINE delete #-}
248 {-# INLINE trace #-}
249 {-# INLINE connect #-}
250 {-# INLINE options #-}
251 {-# INLINE patch #-}