]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-server/Symantic/HTTP/Server.hs
Optimize static routing with a Map instead of (<!>)
[haskell/symantic-http.git] / symantic-http-server / Symantic / HTTP / Server.hs
1 {-# LANGUAGE GADTs #-} -- for 'Router'
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DefaultSignatures #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE UndecidableInstances #-} -- for nested type family application,
7 -- eg. in 'BodyStreamConstraint'
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
10 -- for an example of how to use this module.
11 module Symantic.HTTP.Server where
12
13 import Control.Arrow (first)
14 import Control.Applicative (Applicative(..))
15 import Control.Monad (Monad(..), unless, sequence, guard, (=<<))
16 import Control.Monad.Trans.Class (MonadTrans(..))
17 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
18 import Data.Bool
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Function (($), (.), id, const)
22 import Data.Functor (Functor(..), (<$>))
23 import Data.Int (Int)
24 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
25 import Data.Monoid (Monoid(..))
26 import Data.Ord (Ord(..))
27 import Data.Proxy (Proxy(..))
28 import Data.Semigroup (Semigroup(..))
29 import Data.String (String, IsString(..))
30 import Data.Text (Text)
31 import System.IO (IO)
32 import Text.Show (Show(..))
33 import qualified Control.Monad.Classes as MC
34 import qualified Control.Monad.Trans.Cont as C
35 import qualified Control.Monad.Trans.Reader as R
36 import qualified Control.Monad.Trans.State.Strict as S
37 import qualified Control.Monad.Trans.Writer.Strict as W
38 import qualified Data.ByteString as BS
39 import qualified Data.ByteString.Base64 as BS64
40 import qualified Data.ByteString.Builder as BSB
41 import qualified Data.ByteString.Lazy as BSL
42 import qualified Data.List as List
43 import qualified Data.List.NonEmpty as NonEmpty
44 import qualified Data.Text as Text
45 import qualified Data.Text.Encoding as Text
46 import qualified Data.Word8 as Word8
47 import qualified Network.HTTP.Media as Media
48 import qualified Network.HTTP.Types as HTTP
49 import qualified Network.HTTP.Types.Header as HTTP
50 import qualified Network.Wai as Wai
51 import qualified Web.HttpApiData as Web
52 import qualified Data.Map.Strict as Map
53 import qualified Data.Map.Merge.Strict as Map
54
55 import Symantic.HTTP
56
57 -- * Type 'Server'
58 -- | (@'Server' handlers k@) is a recipe to produce an 'Wai.Application'
59 -- from given ('handlers') (one per number of alternative routes),
60 -- separated by (':!:').
61 --
62 -- 'Server' is analogous to a scanf using the API as a format customized for HTTP routing.
63 --
64 -- The multiple 'ServerCheckT' monad transformers are there
65 -- to prioritize the errors according to the type of check raising them,
66 -- instead of the order of the combinators within an actual API specification.
67 newtype Server handlers k = Server { unServer ::
68 S.StateT ServerState
69 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
70 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
71 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
72 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
73 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
74 (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 or 403 error
75 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
76 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
77 IO))))))))
78 (handlers -> k)
79 }
80
81 -- | (@'server' api handlers@) returns an 'Wai.Application'
82 -- ready to be given to @Warp.run 80@.
83 server ::
84 Router Server handlers (Response Server) ->
85 handlers ->
86 Wai.Application
87 server api handlers rq re = do
88 lrPath <- runServerChecks (unServer $ unTrans $ router api) $ ServerState rq
89 case lrPath of
90 Left err -> respondError HTTP.status404 [] err
91 Right lrMethod ->
92 case lrMethod of
93 Left err -> respondError HTTP.status405 [] err
94 Right lrBasicAuth ->
95 case lrBasicAuth of
96 Left err ->
97 case failError err of
98 [] -> respondError HTTP.status500 [] err
99 ServerErrorBasicAuth realm ba:_ ->
100 case ba of
101 BasicAuth_Unauthorized ->
102 respondError HTTP.status403 [] err
103 _ ->
104 respondError HTTP.status401
105 [ ( HTTP.hWWWAuthenticate
106 , "Basic realm=\""<>Web.toHeader realm<>"\""
107 ) ] err
108 Right lrAccept ->
109 case lrAccept of
110 Left err -> respondError HTTP.status406 [] err
111 Right lrContentType ->
112 case lrContentType of
113 Left err -> respondError HTTP.status415 [] err
114 Right lrQuery ->
115 case lrQuery of
116 Left err -> respondError HTTP.status400 [] err
117 Right lrHeader ->
118 case lrHeader of
119 Left err -> respondError HTTP.status400 [] err
120 Right lrBody ->
121 case lrBody of
122 Left err -> respondError HTTP.status400 [] err
123 Right (app, _st) ->
124 app handlers rq re
125 where
126 respondError ::
127 Show err =>
128 HTTP.Status ->
129 [(HTTP.HeaderName, HeaderValue)] ->
130 err -> IO Wai.ResponseReceived
131 respondError st hs err =
132 -- Trace.trace (show err) $
133 re $ Wai.responseLBS st
134 ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
135 : hs
136 ) (fromString $ show err) -- TODO: see what to return in the body
137
138 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
139 runServerChecks ::
140 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
141 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
142 runServerChecks s st =
143 runExceptT $
144 runExceptT $
145 runExceptT $
146 runExceptT $
147 runExceptT $
148 runExceptT $
149 runExceptT $
150 runExceptT $
151 S.runStateT s st
152
153 -- ** Type 'ServerCheckT'
154 type ServerCheckT e = ExceptT (Fail e)
155
156 -- *** Type 'RouteResult'
157 type RouteResult e = Either (Fail e)
158
159 -- *** Type 'Fail'
160 data Fail e
161 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
162 | FailFatal !ServerState !e -- ^ Don't try other paths.
163 deriving (Show)
164 failState :: Fail e -> ServerState
165 failState (Fail st _) = st
166 failState (FailFatal st _) = st
167 failError :: Fail e -> e
168 failError (Fail _st e) = e
169 failError (FailFatal _st e) = e
170 instance Semigroup e => Semigroup (Fail e) where
171 Fail _ x <> Fail st y = Fail st (x<>y)
172 FailFatal _ x <> Fail st y = FailFatal st (x<>y)
173 Fail _ x <> FailFatal st y = FailFatal st (x<>y)
174 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
175
176 -- ** Type 'ServerState'
177 newtype ServerState = ServerState
178 { serverState_request :: Wai.Request
179 } -- deriving (Show)
180 instance Show ServerState where
181 show _ = "ServerState"
182
183 instance Cat Server where
184 (<.>) ::
185 forall a b c repr.
186 repr ~ Server =>
187 repr a b -> repr b c -> repr a c
188 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
189 -- And if so, fail with y instead of x.
190 --
191 -- This long spaghetti code may probably be avoided
192 -- with a more sophisticated 'Server' using a binary tree
193 -- instead of nested 'Either's, so that its 'Monad' instance
194 -- would do the right thing. But to my mind,
195 -- with the very few priorities of checks currently needed,
196 -- this is not worth the cognitive pain to design it.
197 -- Some copying/pasting/adapting will do for now.
198 Server x <.> Server y = Server $
199 S.StateT $ \st -> do
200 xPath <- MC.exec @IO $ runServerChecks x st
201 case xPath of
202 Left xe -> MC.throw xe
203 Right xMethod ->
204 case xMethod of
205 Left xe -> do
206 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
207 case yPath of
208 Left ye -> MC.throw ye
209 Right _yMethod -> MC.throw xe
210 Right xBasicAuth ->
211 case xBasicAuth of
212 Left xe -> do
213 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
214 case yPath of
215 Left ye -> MC.throw ye
216 Right yMethod ->
217 case yMethod of
218 Left ye -> MC.throw ye
219 Right _yBasicAuth -> MC.throw xe
220 Right xAccept ->
221 case xAccept of
222 Left xe -> do
223 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
224 case yPath of
225 Left ye -> MC.throw ye
226 Right yMethod ->
227 case yMethod of
228 Left ye -> MC.throw ye
229 Right yBasicAuth ->
230 case yBasicAuth of
231 Left ye -> MC.throw ye
232 Right _yAccept -> MC.throw xe
233 Right xContentType ->
234 case xContentType of
235 Left xe -> do
236 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
237 case yPath of
238 Left ye -> MC.throw ye
239 Right yMethod ->
240 case yMethod of
241 Left ye -> MC.throw ye
242 Right yBasicAuth ->
243 case yBasicAuth of
244 Left ye -> MC.throw ye
245 Right yAccept ->
246 case yAccept of
247 Left ye -> MC.throw ye
248 Right _yQuery -> MC.throw xe
249 Right xQuery ->
250 case xQuery of
251 Left xe -> do
252 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
253 case yPath of
254 Left ye -> MC.throw ye
255 Right yMethod ->
256 case yMethod of
257 Left ye -> MC.throw ye
258 Right yBasicAuth ->
259 case yBasicAuth of
260 Left ye -> MC.throw ye
261 Right yAccept ->
262 case yAccept of
263 Left ye -> MC.throw ye
264 Right yQuery ->
265 case yQuery of
266 Left ye -> MC.throw ye
267 Right _yHeader -> MC.throw xe
268 Right xHeader ->
269 case xHeader of
270 Left xe -> do
271 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
272 case yPath of
273 Left ye -> MC.throw ye
274 Right yMethod ->
275 case yMethod of
276 Left ye -> MC.throw ye
277 Right yBasicAuth ->
278 case yBasicAuth of
279 Left ye -> MC.throw ye
280 Right yAccept ->
281 case yAccept of
282 Left ye -> MC.throw ye
283 Right yQuery ->
284 case yQuery of
285 Left ye -> MC.throw ye
286 Right yHeader ->
287 case yHeader of
288 Left ye -> MC.throw ye
289 Right _yBody -> MC.throw xe
290 Right xBody ->
291 case xBody of
292 Left xe -> do
293 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
294 case yPath of
295 Left ye -> MC.throw ye
296 Right yMethod ->
297 case yMethod of
298 Left ye -> MC.throw ye
299 Right yBasicAuth ->
300 case yBasicAuth of
301 Left ye -> MC.throw ye
302 Right yAccept ->
303 case yAccept of
304 Left ye -> MC.throw ye
305 Right yQuery ->
306 case yQuery of
307 Left ye -> MC.throw ye
308 Right yHeader ->
309 case yHeader of
310 Left ye -> MC.throw ye
311 Right _yBody -> MC.throw xe
312 Right (a2b, st') ->
313 (first (. a2b)) <$> S.runStateT y st'
314 instance Alt Server where
315 -- (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
316 Server x <!> Server y = Server $
317 S.StateT $ \st -> do
318 xPath <- MC.exec @IO $ runServerChecks x st
319 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
320 case xPath of
321 Left xe | FailFatal{} <- xe -> MC.throw xe
322 | otherwise -> do
323 yPath <- MC.exec @IO $ runServerChecks y st
324 case yPath of
325 Left ye -> MC.throw (xe<>ye)
326 Right yMethod ->
327 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
328 return $ Right yMethod
329 Right xMethod ->
330 case xMethod of
331 Left xe | FailFatal{} <- xe -> MC.throw xe
332 | otherwise -> do
333 yPath <- MC.exec @IO $ runServerChecks y st
334 case yPath of
335 Left _ye -> MC.throw xe
336 Right yMethod ->
337 case yMethod of
338 Left ye -> MC.throw (xe<>ye)
339 Right yBasicAuth ->
340 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
341 return $ Right $ yBasicAuth
342 Right xBasicAuth ->
343 case xBasicAuth of
344 Left xe | FailFatal{} <- xe -> MC.throw xe
345 | otherwise -> do
346 yPath <- MC.exec @IO $ runServerChecks y st
347 case yPath of
348 Left _ye -> MC.throw xe
349 Right yMethod ->
350 case yMethod of
351 Left _ye -> MC.throw xe
352 Right yBasicAuth ->
353 case yBasicAuth of
354 Left ye -> MC.throw (xe<>ye)
355 Right yAccept ->
356 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
357 return $ Right yAccept
358 Right xAccept ->
359 case xAccept of
360 Left xe | FailFatal{} <- xe -> MC.throw xe
361 | otherwise -> do
362 yPath <- MC.exec @IO $ runServerChecks y st
363 case yPath of
364 Left _ye -> MC.throw xe
365 Right yMethod ->
366 case yMethod of
367 Left _ye -> MC.throw xe
368 Right yBasicAuth ->
369 case yBasicAuth of
370 Left _ye -> MC.throw xe
371 Right yAccept ->
372 case yAccept of
373 Left ye -> MC.throw (xe<>ye)
374 Right yContentType ->
375 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
376 return $ Right yContentType
377 Right xContentType ->
378 case xContentType of
379 Left xe | FailFatal{} <- xe -> MC.throw xe
380 | otherwise -> do
381 yPath <- MC.exec @IO $ runServerChecks y st
382 case yPath of
383 Left _ye -> MC.throw xe
384 Right yMethod ->
385 case yMethod of
386 Left _ye -> MC.throw xe
387 Right yBasicAuth ->
388 case yBasicAuth of
389 Left _ye -> MC.throw xe
390 Right yAccept ->
391 case yAccept of
392 Left _ye -> MC.throw xe
393 Right yContentType ->
394 case yContentType of
395 Left ye -> MC.throw (xe<>ye)
396 Right yQuery ->
397 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
398 return $ Right yQuery
399 Right xQuery ->
400 case xQuery of
401 Left xe | FailFatal{} <- xe -> MC.throw xe
402 | otherwise -> do
403 yPath <- MC.exec @IO $ runServerChecks y st
404 case yPath of
405 Left _ye -> MC.throw xe
406 Right yMethod ->
407 case yMethod of
408 Left _ye -> MC.throw xe
409 Right yBasicAuth ->
410 case yBasicAuth of
411 Left _ye -> MC.throw xe
412 Right yAccept ->
413 case yAccept of
414 Left _ye -> MC.throw xe
415 Right yContentType ->
416 case yContentType of
417 Left _ye -> MC.throw xe
418 Right yQuery ->
419 case yQuery of
420 Left ye -> MC.throw (xe<>ye)
421 Right yHeader ->
422 fy $ ExceptT $ ExceptT $ ExceptT $
423 return $ Right yHeader
424 Right xHeader ->
425 case xHeader of
426 Left xe | FailFatal{} <- xe -> MC.throw xe
427 | otherwise -> do
428 yPath <- MC.exec @IO $ runServerChecks y st
429 case yPath of
430 Left _ye -> MC.throw xe
431 Right yMethod ->
432 case yMethod of
433 Left _ye -> MC.throw xe
434 Right yBasicAuth ->
435 case yBasicAuth of
436 Left _ye -> MC.throw xe
437 Right yAccept ->
438 case yAccept of
439 Left _ye -> MC.throw xe
440 Right yContentType ->
441 case yContentType of
442 Left _ye -> MC.throw xe
443 Right yQuery ->
444 case yQuery of
445 Left _ye -> MC.throw xe
446 Right yHeader ->
447 case yHeader of
448 Left ye -> MC.throw (xe<>ye)
449 Right yBody ->
450 fy $ ExceptT $ ExceptT $
451 return $ Right yBody
452 Right xBody ->
453 case xBody of
454 Left xe | FailFatal{} <- xe -> MC.throw xe
455 | otherwise -> do
456 yPath <- MC.exec @IO $ runServerChecks y st
457 case yPath of
458 Left _ye -> MC.throw xe
459 Right yMethod ->
460 case yMethod of
461 Left _ye -> MC.throw xe
462 Right yBasicAuth ->
463 case yBasicAuth of
464 Left _ye -> MC.throw xe
465 Right yAccept ->
466 case yAccept of
467 Left _ye -> MC.throw xe
468 Right yContentType ->
469 case yContentType of
470 Left _ye -> MC.throw xe
471 Right yQuery ->
472 case yQuery of
473 Left _ye -> MC.throw xe
474 Right yHeader ->
475 case yHeader of
476 Left _ye -> MC.throw xe
477 Right yBody ->
478 case yBody of
479 Left ye -> MC.throw (xe<>ye)
480 Right yr ->
481 fy $ ExceptT $
482 return $ Right yr
483 Right xr ->
484 return $ first (\a2k (a:!:_b) -> a2k a) xr
485 instance Pro Server where
486 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
487
488 -- ** Type 'ServerErrorPath'
489 newtype ServerErrorPath = ServerErrorPath Text
490 deriving (Eq, Show)
491
492 instance HTTP_Path Server where
493 type PathConstraint Server a = Web.FromHttpApiData a
494 segment expSegment = Server $ do
495 st@ServerState
496 { serverState_request = req
497 } <- S.get
498 case Wai.pathInfo req of
499 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
500 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
501 curr:next
502 | curr /= expSegment ->
503 MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr]
504 | otherwise -> do
505 S.put st
506 { serverState_request = req{ Wai.pathInfo = next }
507 }
508 return id
509 capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k
510 capture' name = Server $ do
511 st@ServerState
512 { serverState_request = req
513 } <- S.get
514 case Wai.pathInfo req of
515 [] -> MC.throw $ Fail st [ServerErrorPath "empty"]
516 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
517 curr:next ->
518 case Web.parseUrlPiece curr of
519 Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err]
520 Right a -> do
521 S.put st
522 { serverState_request = req{ Wai.pathInfo = next }
523 }
524 return ($ a)
525 captureAll = Server $ do
526 req <- S.gets serverState_request
527 return ($ Wai.pathInfo req)
528
529 -- ** Type 'ServerErrorMethod'
530 data ServerErrorMethod = ServerErrorMethod
531 deriving (Eq, Show)
532
533 -- | TODO: add its own error?
534 instance HTTP_Version Server where
535 version exp = Server $ do
536 st <- S.get
537 let got = Wai.httpVersion $ serverState_request st
538 if got == exp
539 then return id
540 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
541
542 -- ** Type 'ServerErrorAccept'
543 data ServerErrorAccept =
544 ServerErrorAccept
545 MediaTypes
546 (Maybe (Either BS.ByteString MediaType))
547 deriving (Eq, Show)
548
549 -- ** Type 'ServerErrorContentType'
550 data ServerErrorContentType = ServerErrorContentType
551 deriving (Eq, Show)
552
553 -- ** Type 'ServerErrorQuery'
554 newtype ServerErrorQuery = ServerErrorQuery Text
555 deriving (Show)
556 instance HTTP_Query Server where
557 type QueryConstraint Server a = Web.FromHttpApiData a
558 queryParams' name = Server $ do
559 st <- S.get
560 lift $ ExceptT $ ExceptT $ ExceptT $ return $
561 let qs = Wai.queryString $ serverState_request st in
562 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
563 if n == name
564 then Web.parseQueryParam . Text.decodeUtf8 <$> v
565 else Nothing in
566 case sequence vals of
567 Left err -> Left $ Fail st [ServerErrorQuery err]
568 Right vs -> Right $ Right $ Right ($ vs)
569
570 -- ** Type 'ServerErrorHeader'
571 data ServerErrorHeader = ServerErrorHeader
572 deriving (Eq, Show)
573 instance HTTP_Header Server where
574 header n = Server $ do
575 st <- S.get
576 lift $ ExceptT $ ExceptT $ return $
577 let hs = Wai.requestHeaders $ serverState_request st in
578 case List.lookup n hs of
579 Nothing -> Left $ Fail st [ServerErrorHeader]
580 Just v -> Right $ Right ($ v)
581
582 -- ** Type 'ServerErrorBasicAuth'
583 data ServerErrorBasicAuth =
584 ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
585 deriving (Show)
586
587 -- ** Class 'ServerBasicAuth'
588 -- | Custom 'BasicAuth' check.
589 class ServerBasicAuth a where
590 serverBasicAuth ::
591 BasicAuthUser ->
592 BasicAuthPass ->
593 IO (BasicAuth a)
594
595 -- | WARNING: current implementation of Basic Access Authentication
596 -- is not immune to certain kinds of timing attacks.
597 -- Decoding payloads does not take a fixed amount of time.
598 instance HTTP_BasicAuth Server where
599 type BasicAuthConstraint Server a = ServerBasicAuth a
600 type BasicAuthArgs Server a k = a -> k
601 basicAuth' realm = Server $ do
602 st <- S.get
603 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
604 case decodeAuthorization $ serverState_request st of
605 Nothing -> err BasicAuth_BadPassword
606 Just (user, pass) -> do
607 MC.exec @IO (serverBasicAuth user pass) >>= \case
608 BasicAuth_BadPassword -> err BasicAuth_BadPassword
609 BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser
610 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
611 BasicAuth_Authorized u -> return ($ u)
612 where
613 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
614 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
615 decodeAuthorization req = do
616 hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
617 let (basic, rest) = BS.break Word8.isSpace hAuthorization
618 guard (BS.map Word8.toLower basic == "basic")
619 let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
620 let (user, colon_pass) = BS.break (== Word8._colon) decoded
621 (_, pass) <- BS.uncons colon_pass
622 return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
623
624 -- ** Type 'ServerErrorBody'
625 newtype ServerErrorBody = ServerErrorBody String
626 deriving (Eq, Show)
627
628 -- *** Type 'ServerBodyArg'
629 newtype ServerBodyArg (ts::[*]) a = ServerBodyArg a
630
631 instance HTTP_Body Server where
632 type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
633 type BodyArg Server a ts = ServerBodyArg ts a
634 body' ::
635 forall a ts k repr.
636 BodyConstraint repr a ts =>
637 repr ~ Server =>
638 repr (BodyArg repr a ts -> k) k
639 body'= Server $ do
640 st <- S.get
641 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
642 let hs = Wai.requestHeaders $ serverState_request st
643 let reqContentType =
644 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
645 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
646 fromMaybe "application/octet-stream" $
647 List.lookup HTTP.hContentType hs
648 case matchContent @ts @(MimeDecodable a) reqContentType of
649 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
650 Just (MimeType mt) -> do
651 bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st
652 return $ Right $ Right $ Right $
653 -- NOTE: delay 'mimeDecode' after all checks
654 case mimeDecode mt $ BSL.fromStrict bodyBS of
655 Left err -> Left $ Fail st [ServerErrorBody err]
656 Right a -> Right ($ ServerBodyArg a)
657
658 -- *** Type 'ServerBodyStreamArg'
659 newtype ServerBodyStreamArg as (ts::[*]) framing
660 = ServerBodyStreamArg as
661 instance HTTP_BodyStream Server where
662 type BodyStreamConstraint Server as ts framing =
663 ( FramingDecode framing as
664 , MC.MonadExec IO (FramingMonad as)
665 , MimeTypes ts (MimeDecodable (FramingYield as))
666 )
667 type BodyStreamArg Server as ts framing =
668 ServerBodyStreamArg as ts framing
669 bodyStream' ::
670 forall as ts framing k repr.
671 BodyStreamConstraint repr as ts framing =>
672 repr ~ Server =>
673 repr (BodyStreamArg repr as ts framing -> k) k
674 bodyStream'= Server $ do
675 st <- S.get
676 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
677 let hs = Wai.requestHeaders $ serverState_request st
678 let reqContentType =
679 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
680 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
681 fromMaybe "application/octet-stream" $
682 List.lookup HTTP.hContentType hs
683 case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
684 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
685 Just (MimeType mt) -> do
686 let bodyBS = Wai.requestBody $ serverState_request st
687 return $ Right $ Right $ Right $
688 Right ($ ServerBodyStreamArg $
689 framingDecode (Proxy @framing) (mimeDecode mt) $
690 MC.exec @IO bodyBS
691 )
692
693 -- * Type 'ServerResponse'
694 -- | A continuation for 'server''s users to respond.
695 --
696 -- This newtype has two uses :
697 --
698 -- * Carrying the 'ts' type variable to 'server'.
699 -- * Providing a 'return' for the simple response case
700 -- of 'HTTP.status200' and no extra headers.
701 newtype ServerRes (ts::[*]) m a
702 = ServerResponse
703 { unServerResponse :: m a
704 } deriving (Functor, Applicative, Monad)
705 type ServerResponse ts m = ServerRes ts
706 (R.ReaderT Wai.Request
707 (W.WriterT HTTP.ResponseHeaders
708 (W.WriterT HTTP.Status
709 (C.ContT Wai.Response m))))
710 instance MonadTrans (ServerRes ts) where
711 lift = ServerResponse
712 -- | All supported effects are handled by nested 'Monad's.
713 type instance MC.CanDo (ServerResponse ts m) eff = 'False
714 type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False
715
716 instance HTTP_Response Server where
717 type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
718 type ResponseArgs Server a ts = ServerResponse ts IO a
719 type Response Server =
720 Wai.Request ->
721 (Wai.Response -> IO Wai.ResponseReceived) ->
722 IO Wai.ResponseReceived
723 response ::
724 forall a ts repr.
725 ResponseConstraint repr a ts =>
726 repr ~ Server =>
727 HTTP.Method ->
728 repr (ResponseArgs repr a ts)
729 (Response repr)
730 response expMethod = Server $ do
731 st@ServerState
732 { serverState_request = req
733 } <- S.get
734
735 -- Check the path has been fully consumed
736 unless (List.null $ Wai.pathInfo req) $
737 MC.throw $ Fail st [ServerErrorPath "path is longer"]
738
739 -- Check the method
740 let reqMethod = Wai.requestMethod $ serverState_request st
741 unless (reqMethod == expMethod
742 || reqMethod == HTTP.methodHead
743 && expMethod == HTTP.methodGet) $
744 MC.throw $ Fail st [ServerErrorMethod]
745
746 -- Check the Accept header
747 let reqHeaders = Wai.requestHeaders $ serverState_request st
748 MimeType reqAccept <- do
749 case List.lookup HTTP.hAccept reqHeaders of
750 Nothing ->
751 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
752 Just h ->
753 case matchAccept @ts @(MimeEncodable a) h of
754 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
755 Just mt -> return mt
756
757 return $ \(ServerResponse k) rq re -> re =<< do
758 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
759 return{-IO-} $
760 Wai.responseLBS sta
761 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
762 (if reqMethod == HTTP.methodHead
763 then ""
764 else mimeEncode reqAccept a)
765
766 -- * Type 'ServerResponseStream'
767 --
768 -- This newtype has three uses :
769 --
770 -- * Carrying the 'framing' type variable to 'server'.
771 -- * Carrying the 'ts' type variable to 'server'.
772 -- * Providing a 'return' for the simple response case
773 -- of 'HTTP.status200' and no extra headers.
774 newtype ServerResStream framing (ts::[*]) m as
775 = ServerResponseStream
776 { unServerResponseStream :: m as
777 } deriving (Functor, Applicative, Monad)
778 instance MonadTrans (ServerResStream framing ts) where
779 lift = ServerResponseStream
780 type ServerResponseStream framing ts m = ServerResStream framing ts
781 (R.ReaderT Wai.Request
782 (W.WriterT HTTP.ResponseHeaders
783 (W.WriterT HTTP.Status
784 (C.ContT Wai.Response m))))
785 -- | All supported effects are handled by nested 'Monad's.
786 type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False
787
788 instance HTTP_ResponseStream Server where
789 type ResponseStreamConstraint Server as ts framing =
790 ( FramingEncode framing as
791 , MimeTypes ts (MimeEncodable (FramingYield as))
792 )
793 type ResponseStreamArgs Server as ts framing =
794 ServerResponseStream framing ts IO as
795 type ResponseStream Server =
796 Wai.Request ->
797 (Wai.Response -> IO Wai.ResponseReceived) ->
798 IO Wai.ResponseReceived
799 responseStream ::
800 forall as ts framing repr.
801 ResponseStreamConstraint repr as ts framing =>
802 repr ~ Server =>
803 HTTP.Method ->
804 repr (ResponseStreamArgs repr as ts framing)
805 (ResponseStream repr)
806 responseStream expMethod = Server $ do
807 st@ServerState
808 { serverState_request = req
809 } <- S.get
810
811 -- Check the path has been fully consumed
812 unless (List.null $ Wai.pathInfo req) $
813 MC.throw $ Fail st [ServerErrorPath "path is longer"]
814
815 -- Check the method
816 let reqMethod = Wai.requestMethod $ serverState_request st
817 unless (reqMethod == expMethod
818 || reqMethod == HTTP.methodHead
819 && expMethod == HTTP.methodGet) $
820 MC.throw $ Fail st [ServerErrorMethod]
821
822 -- Check the Accept header
823 let reqHeaders = Wai.requestHeaders $ serverState_request st
824 MimeType reqAccept <- do
825 case List.lookup HTTP.hAccept reqHeaders of
826 Nothing ->
827 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
828 Just h ->
829 case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
830 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
831 Just mt -> return mt
832
833 return $ \(ServerResponseStream k) rq re -> re =<< do
834 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
835 return{-IO-} $
836 Wai.responseStream sta
837 ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
838 : hs
839 ) $ \write flush ->
840 if reqMethod == HTTP.methodHead
841 then flush
842 else
843 let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
844 let go curr =
845 case curr of
846 Left _end -> flush
847 Right (bsl, next) -> do
848 unless (BSL.null bsl) $ do
849 write (BSB.lazyByteString bsl)
850 flush
851 enc next >>= go
852 in enc as >>= go
853
854 -- | Return worse 'HTTP.Status'.
855 instance Semigroup HTTP.Status where
856 x <> y =
857 if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
858 then x
859 else y
860 where
861 rank :: Int -> Int
862 rank 404 = 0 -- Not Found
863 rank 405 = 1 -- Method Not Allowed
864 rank 401 = 2 -- Unauthorized
865 rank 415 = 3 -- Unsupported Media Type
866 rank 406 = 4 -- Not Acceptable
867 rank 400 = 5 -- Bad Request
868 rank _ = 6
869 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
870 instance Monoid HTTP.Status where
871 mempty = HTTP.status200
872 mappend = (<>)
873
874
875 -- * Type 'Router'
876 -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.
877 data Router repr a b where
878 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
879 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
880 Router_Any :: repr a b -> Router repr a b
881 -- | Represent 'segment'.
882 Router_Seg :: PathSegment -> Router repr a a
883 -- | Represent ('<.>').
884 Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
885 -- | Represent 'routing'.
886 Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
887 -- | Represent ('<!>').
888 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
889 -- | Used to transform 'Router_Alt' into 'Router_Map',
890 -- while following the way ('<!>') combinators are associated in the API.
891 -- Use 'router_AltL' to insert it correctly.
892 Router_AltL :: Router repr a k -> Router repr (a:!:b) k
893 -- | Used to transform 'Router_Alt' into 'Router_Map'
894 -- while following the way ('<!>') combinators are associated in the API.
895 -- Use 'router_AltR' to insert it correctly.
896 Router_AltR :: Router repr b k -> Router repr (a:!:b) k
897 -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k
898
899 instance Trans (Router Server) where
900 type UnTrans (Router Server) = Server
901 noTrans = Router_Any
902 unTrans (Router_Any x) = x
903 unTrans (Router_Seg s) = segment s
904 unTrans (Router_Cat x y) = unTrans x <.> unTrans y
905 unTrans (Router_Alt x y) = unTrans x <!> unTrans y
906 unTrans (Router_AltL x) = Server $ (\a2k (a:!:_b) -> a2k a) <$> unServer (unTrans x)
907 unTrans (Router_AltR x) = Server $ (\b2k (_a:!:b) -> b2k b) <$> unServer (unTrans x)
908 unTrans (Router_Map ms) = routing (unTrans <$> ms)
909 -- unTrans (Router_AltB x) = Server $ (\a2k a -> a2k (a:!:a)) <$> unServer (unTrans x)
910
911 -- | Traverse a 'Router' to transform 'Router_Alt'
912 -- into 'Router_Map' when possible.
913 -- Used in 'server' on the 'Router' inferred from the given API.
914 router :: Router repr a b -> Router repr a b
915 router = \case
916 x@Router_Any{} -> x
917 x@Router_Seg{} -> x
918 Router_Cat x y -> router x `Router_Cat` router y
919 Router_Alt x y -> router_Alt x y
920 Router_AltL x -> Router_AltL (router x)
921 Router_AltR x -> Router_AltR (router x)
922 Router_Map xs -> Router_Map (router <$> xs)
923
924 -- | Insert a 'Router_Alt' or a 'Router_Map' if possible.
925 router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
926 router_Alt (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) =
927 Router_Map $ Map.fromListWith
928 (\_xt _yt -> xt `router_Alt` yt)
929 [ (x, router_AltL xt)
930 , (y, router_AltR yt)
931 ]
932 router_Alt (Router_Seg x `Router_Cat` xt) (Router_Map ys) =
933 Router_Map $
934 Map.merge
935 (Map.traverseMissing $ const $ return . router_AltL)
936 (Map.traverseMissing $ const $ return . router_AltR)
937 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
938 (Map.singleton x xt) ys
939 router_Alt (Router_Map xs) (Router_Seg y `Router_Cat` yt) =
940 Router_Map $
941 Map.merge
942 (Map.traverseMissing $ const $ return . router_AltL)
943 (Map.traverseMissing $ const $ return . router_AltR)
944 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
945 xs (Map.singleton y yt)
946 router_Alt (Router_Map xs) (Router_Map ys) =
947 Router_Map $
948 Map.merge
949 (Map.traverseMissing $ const $ return . router_AltL)
950 (Map.traverseMissing $ const $ return . router_AltR)
951 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
952 xs ys
953 router_Alt (Router_Cat (Router_Cat x y) z) w = router_Alt (Router_Cat x (Router_Cat y z)) w
954 router_Alt w (Router_Cat (Router_Cat x y) z) = router_Alt w (Router_Cat x (Router_Cat y z))
955 router_Alt x (Router_Alt y z) = router_Alt x (router_Alt y z)
956 router_Alt (Router_Alt x y) z = router_Alt (router_Alt x y) z
957 router_Alt x y = Router_Alt x y
958
959 -- | Insert a 'Router_AltL' as deep as possible
960 -- in order to not prevent the transformation
961 -- of 'Router_Alt' into 'Router_Map' in 'router_Alt'.
962 router_AltL :: Router repr a k -> Router repr (a:!:b) k
963 router_AltL = \case
964 Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltL y)
965 Router_Cat x y -> Router_Cat (router_AltL x) y
966 Router_Alt x y -> router_AltL (router_Alt x y)
967 Router_Map xs -> Router_Map (router_AltL <$> xs)
968 d -> Router_AltL d
969
970 -- | Like 'router_AltL' but for 'Router_AltR'.
971 router_AltR :: Router repr b k -> Router repr (a:!:b) k
972 router_AltR = \case
973 Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltR y)
974 Router_Cat x y -> Router_Cat (router_AltR x) y
975 Router_Alt x y -> router_AltR (router_Alt x y)
976 Router_Map xs -> Router_Map (router_AltR <$> xs)
977 d -> Router_AltR d
978
979 instance Cat (Router Server) where
980 (<.>) = Router_Cat
981 instance Alt (Router Server) where
982 (<!>) = Router_Alt
983 instance HTTP_Path (Router Server) where
984 segment = Router_Seg
985 instance HTTP_Routing (Router Server) where
986 routing = Router_Map
987 instance Pro (Router Server)
988 instance HTTP_Query (Router Server)
989 instance HTTP_Header (Router Server)
990 instance HTTP_Body (Router Server)
991 instance HTTP_BodyStream (Router Server)
992 instance HTTP_BasicAuth (Router Server)
993 instance HTTP_Response (Router Server)
994 instance HTTP_ResponseStream (Router Server)
995
996 -- ** Class 'HTTP_Routing'
997 class HTTP_Routing repr where
998 routing :: Map.Map PathSegment (repr a k) -> repr a k
999 -- Trans defaults
1000 default routing ::
1001 Trans repr =>
1002 HTTP_Routing (UnTrans repr) =>
1003 Map.Map PathSegment (repr a k) -> repr a k
1004 routing = noTrans . routing . (unTrans <$>)
1005
1006 instance HTTP_Routing Server where
1007 routing ms = Server $ do
1008 st@ServerState
1009 { serverState_request = req
1010 } <- S.get
1011 case Wai.pathInfo req of
1012 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
1013 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1014 curr:next ->
1015 case Map.lookup curr ms of
1016 Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]
1017 Just m -> do
1018 S.put st
1019 { serverState_request = req{ Wai.pathInfo = next }
1020 }
1021 unServer m
1022
1023 {-
1024 -- ** Class 'ReprEq'
1025 class ReprEq repr where
1026 reprEq :: repr a b -> repr c d -> Maybe ((a,b):~:(c,d))
1027 instance ReprEq repr => ReprEq (Router repr) where
1028 reprEq
1029 (Router_Any x)
1030 (Router_Any y) = reprEq x y
1031 reprEq
1032 (Router_Seg x `Router_Cat` xt)
1033 (Router_Seg y `Router_Cat` yt)
1034 | x == y
1035 , Just Refl <- reprEq xt yt
1036 = Just Refl
1037 reprEq
1038 (Router_Map xs)
1039 (Router_Map ys) =
1040 go (Map.toList xs) (Map.toList ys)
1041 where
1042 go ::
1043 [(PathSegment, Router repr a b)] ->
1044 [(PathSegment, Router repr c d)] ->
1045 Maybe ((a,b):~:(c,d))
1046 go ((ak,at):[]) ((bk,bt):[])
1047 | ak == bk
1048 , Just Refl <- reprEq at bt
1049 = Just Refl
1050 go ((ak,at):as) ((bk,bt):bs)
1051 | ak == bk
1052 , Just Refl <- reprEq at bt
1053 = go as bs
1054 go _ _ = Nothing
1055 -- NOTE: if the routing is empty there is no way to return the Refl proof.
1056 reprEq
1057 (Router_Cat xa2b xb2c)
1058 (Router_Cat ya2b yb2c)
1059 | Just Refl <- reprEq xa2b ya2b
1060 , Just Refl <- reprEq xb2c yb2c
1061 = Just Refl
1062 reprEq
1063 (Router_Alt xl xr)
1064 (Router_Alt yl yr)
1065 | Just Refl <- reprEq xl yl
1066 , Just Refl <- reprEq xr yr
1067 = Just Refl
1068 {-
1069 reprEq
1070 (Router_AltL x)
1071 (Router_AltL y)
1072 | Just Refl <- reprEq x y
1073 = Just Refl
1074 -}
1075 {-
1076 Router_Map xs == Router_Map ys = xs == ys
1077 Router_Cat xa2b xb2c == Router_Cat ya2b yb2c =
1078 | Just Refl <- testEquality
1079 xa2b == ya2b &&
1080 xb2c == yb2c
1081 -}
1082 -}