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