1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE ConstraintKinds #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
7 {-# LANGUAGE InstanceSigs #-}
8 {-# LANGUAGE OverloadedStrings #-}
9 {-# LANGUAGE Rank2Types #-}
10 {-# LANGUAGE TypeApplications #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# LANGUAGE TypeOperators #-}
13 module Symantic.HTTP.Server where
15 import Control.Arrow (first)
16 import Control.Monad (Monad(..), unless, sequence, guard)
17 import Control.Monad.Trans.Class (MonadTrans(..))
18 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
20 import Data.Either (Either(..))
21 import Data.Eq (Eq(..))
22 import Data.Function (($), (.), id)
23 import Data.Functor (Functor, (<$>))
25 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
26 import Data.Semigroup (Semigroup(..))
27 import Data.String (String, IsString(..))
28 import Data.Text (Text)
31 import Text.Show (Show(..))
32 import qualified Control.Monad.Classes as MC
33 import qualified Control.Monad.Trans.State as S
34 import qualified Data.ByteString as BS
35 import qualified Data.ByteString.Base64 as BS64
36 import qualified Data.ByteString.Lazy as BSL
37 import qualified Data.List as List
38 import qualified Data.Text.Encoding as Text
39 import qualified Data.Word8 as Word8
40 import qualified Network.HTTP.Media as Media
41 import qualified Network.HTTP.Types as HTTP
42 import qualified Network.HTTP.Types.Header as HTTP
43 import qualified Network.Wai as Wai
44 import qualified Web.HttpApiData as Web
46 import Symantic.HTTP.API
47 import Symantic.HTTP.Mime
50 -- | @Server f k@ is a recipe to produce an 'Wai.Application'
51 -- from handlers 'f' (one per number of alternative routes).
53 -- 'Server' is analogous to a scanf using a format customized for HTTP routing.
55 -- The multiple monad transformers are there to prioritize the errors
56 -- according to the type of check raising them,
57 -- instead of the order of the combinators within an actual API specification.
58 newtype Server f k = Server { unServer ::
60 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
61 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
62 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
63 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
64 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
65 (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 error
66 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
67 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
72 -- | @'server' api handlers@ returns a 'Wai.Application'
73 -- ready to be given to @Warp.run 80@.
75 Server handlers ServerResponse ->
78 server (Server api) handlers rq re = do
79 lrPath <- runServerChecks api $ ServerState 0 rq
81 Left err -> respondError status404 [] err
84 Left err -> respondError status405 [] err
89 [] -> respondError status500 [] err
90 ServerErrorBasicAuth realm ba:_ ->
92 BasicAuth_Unauthorized ->
93 respondError status403 [] err
95 respondError status401
96 [ ( HTTP.hWWWAuthenticate
97 , "Basic realm=\""<>Web.toHeader realm<>"\""
101 Left err -> respondError status406 [] err
102 Right lrContentType ->
103 case lrContentType of
104 Left err -> respondError status415 [] err
107 Left err -> respondError status400 [] err
110 Left err -> respondError status400 [] err
113 Left err -> respondError status400 [] err
115 let ServerResponse app = a2k handlers in
121 [(HTTP.HeaderName, HeaderValue)] ->
122 err -> IO Wai.ResponseReceived
123 respondError st hs err =
124 -- Trace.trace (show err) $
125 re $ Wai.responseLBS st
126 ( (HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)
128 ) (fromString $ show err) -- TODO: see what to return in the body
131 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
133 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
134 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
135 runServerChecks s st =
146 -- ** Type 'ServerCheckT'
147 type ServerCheckT e = ExceptT (Fail e)
149 -- *** Type 'RouteResult'
150 type RouteResult e = Either (Fail e)
154 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
155 | FailFatal !ServerState !e -- ^ Don't try other paths.
157 failState :: Fail e -> ServerState
158 failState (Fail st _) = st
159 failState (FailFatal st _) = st
160 failError :: Fail e -> e
161 failError (Fail _st e) = e
162 failError (FailFatal _st e) = e
163 instance Semigroup e => Semigroup (Fail e) where
164 Fail _ x <> Fail st y = Fail st (x<>y)
165 FailFatal _ x <> Fail st y = FailFatal st (x<>y)
166 Fail _ x <> FailFatal st y = FailFatal st (x<>y)
167 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
169 -- ** Type 'ServerState'
170 data ServerState = ServerState
171 { serverState_offset :: Offset -- TODO: remove
172 , serverState_request :: Wai.Request
176 instance Show ServerState where
177 show _ = "ServerState"
179 type instance HttpApiData Server = Web.FromHttpApiData
180 instance Cat Server where
184 repr a b -> repr b c -> repr a c
185 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
186 -- And if so, fail with y instead of x.
188 -- This long spaghetti code may probably be avoided
189 -- with a more sophisticated 'Server' using a binary tree
190 -- instead of nested 'Either's, so that its 'Monad' instance
191 -- would do the right thing. But to my mind,
192 -- with the very few priorities of checks currently needed,
193 -- this is not worth the cognitive pain to design it.
194 -- A copy/paste/adapt will do for now.
195 Server x <.> Server y = Server $
197 xPath <- liftIO $ runServerChecks x st
199 Left xe -> MC.throw xe
203 yPath <- liftIO $ runServerChecks y (failState xe)
205 Left ye -> MC.throw ye
206 Right _yMethod -> MC.throw xe
210 yPath <- liftIO $ runServerChecks y (failState xe)
212 Left ye -> MC.throw ye
215 Left ye -> MC.throw ye
216 Right _yBasicAuth -> MC.throw xe
220 yPath <- liftIO $ runServerChecks y (failState xe)
222 Left ye -> MC.throw ye
225 Left ye -> MC.throw ye
228 Left ye -> MC.throw ye
229 Right _yAccept -> MC.throw xe
230 Right xContentType ->
233 yPath <- liftIO $ runServerChecks y (failState xe)
235 Left ye -> MC.throw ye
238 Left ye -> MC.throw ye
241 Left ye -> MC.throw ye
244 Left ye -> MC.throw ye
245 Right _yQuery -> MC.throw xe
249 yPath <- liftIO $ runServerChecks y (failState xe)
251 Left ye -> MC.throw ye
254 Left ye -> MC.throw ye
257 Left ye -> MC.throw ye
260 Left ye -> MC.throw ye
263 Left ye -> MC.throw ye
264 Right _yHeader -> MC.throw xe
268 yPath <- liftIO $ runServerChecks y (failState xe)
270 Left ye -> MC.throw ye
273 Left ye -> MC.throw ye
276 Left ye -> MC.throw ye
279 Left ye -> MC.throw ye
282 Left ye -> MC.throw ye
285 Left ye -> MC.throw ye
286 Right _yBody -> MC.throw xe
290 yPath <- liftIO $ runServerChecks y (failState xe)
292 Left ye -> MC.throw ye
295 Left ye -> MC.throw ye
298 Left ye -> MC.throw ye
301 Left ye -> MC.throw ye
304 Left ye -> MC.throw ye
307 Left ye -> MC.throw ye
308 Right _yBody -> MC.throw xe
310 (first (. a2b)) <$> S.runStateT y st'
311 instance Alt Server where
312 Server x <!> Server y = Server $
314 xPath <- liftIO $ runServerChecks x st
315 yPath <- liftIO $ runServerChecks y st
316 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
318 Left xe | FailFatal{} <- xe -> MC.throw xe
321 Left ye -> MC.throw (xe<>ye)
323 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
324 return $ Right yMethod
327 Left xe | FailFatal{} <- xe -> MC.throw xe
330 Left _ye -> MC.throw xe
333 Left ye -> MC.throw (xe<>ye)
335 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
336 return $ Right $ yBasicAuth
339 Left xe | FailFatal{} <- xe -> MC.throw xe
342 Left _ye -> MC.throw xe
345 Left _ye -> MC.throw xe
348 Left ye -> MC.throw (xe<>ye)
350 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
351 return $ Right yAccept
354 Left xe | FailFatal{} <- xe -> MC.throw xe
357 Left _ye -> MC.throw xe
360 Left _ye -> MC.throw xe
363 Left _ye -> MC.throw xe
366 Left ye -> MC.throw (xe<>ye)
367 Right yContentType ->
368 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
369 return $ Right yContentType
370 Right xContentType ->
372 Left xe | FailFatal{} <- xe -> MC.throw xe
375 Left _ye -> MC.throw xe
378 Left _ye -> MC.throw xe
381 Left _ye -> MC.throw xe
384 Left _ye -> MC.throw xe
385 Right yContentType ->
387 Left ye -> MC.throw (xe<>ye)
389 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
390 return $ Right yQuery
393 Left xe | FailFatal{} <- xe -> MC.throw xe
396 Left _ye -> MC.throw xe
399 Left _ye -> MC.throw xe
402 Left _ye -> MC.throw xe
405 Left _ye -> MC.throw xe
406 Right yContentType ->
408 Left _ye -> MC.throw xe
411 Left ye -> MC.throw (xe<>ye)
413 fy $ ExceptT $ ExceptT $ ExceptT $
414 return $ Right yHeader
417 Left xe | FailFatal{} <- xe -> MC.throw xe
420 Left _ye -> MC.throw xe
423 Left _ye -> MC.throw xe
426 Left _ye -> MC.throw xe
429 Left _ye -> MC.throw xe
430 Right yContentType ->
432 Left _ye -> MC.throw xe
435 Left _ye -> MC.throw xe
438 Left ye -> MC.throw (xe<>ye)
440 fy $ ExceptT $ ExceptT $
444 Left xe | FailFatal{} <- xe -> MC.throw xe
447 Left _ye -> MC.throw xe
450 Left _ye -> MC.throw xe
453 Left _ye -> MC.throw xe
456 Left _ye -> MC.throw xe
457 Right yContentType ->
459 Left _ye -> MC.throw xe
462 Left _ye -> MC.throw xe
465 Left _ye -> MC.throw xe
468 Left ye -> MC.throw (xe<>ye)
473 return $ first (\a2k (a:!:_b) -> a2k a) xr
474 instance Pro Server where
475 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
477 -- ** Type 'ServerErrorPath'
478 data ServerErrorPath = ServerErrorPath Offset Text
480 instance HTTP_Path Server where
481 segment expSegment = Server $ do
483 { serverState_offset = o
484 , serverState_request = req
486 case Wai.pathInfo req of
487 [] -> MC.throw $ Fail st [ServerErrorPath o "segment: empty"]
488 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
490 | curr /= expSegment ->
491 MC.throw $ Fail st [ServerErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
494 { serverState_offset = o+1
495 , serverState_request = req{ Wai.pathInfo = next }
498 capture' :: forall a k. HttpApiData Server a => Name -> Server (a -> k) k
499 capture' name = Server $ do
501 { serverState_offset = o
502 , serverState_request = req
504 case Wai.pathInfo req of
505 [] -> MC.throw $ Fail st [ServerErrorPath o "empty"]
506 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
508 case Web.parseUrlPiece curr of
509 Left err -> MC.throw $ Fail st [ServerErrorPath o $ "capture: "<>fromString name<>": "<>err]
512 { serverState_offset = o+1
513 , serverState_request = req{ Wai.pathInfo = next }
516 captureAll = Server $ do
517 req <- S.gets serverState_request
518 return ($ Wai.pathInfo req)
520 -- ** Type 'ServerErrorMethod'
521 data ServerErrorMethod = ServerErrorMethod
524 -- | TODO: add its own error?
525 instance HTTP_Version Server where
526 version exp = Server $ do
528 let got = Wai.httpVersion $ serverState_request st
531 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
533 -- ** Type 'ServerErrorAccept'
534 data ServerErrorAccept =
537 (Maybe (Either BS.ByteString MediaType))
540 -- ** Type 'ServerErrorContentType'
541 data ServerErrorContentType = ServerErrorContentType
544 -- ** Type 'ServerErrorQuery'
545 newtype ServerErrorQuery = ServerErrorQuery Text
547 instance HTTP_Query Server where
548 queryParams' name = Server $ do
550 lift $ ExceptT $ ExceptT $ ExceptT $ return $
551 let qs = Wai.queryString $ serverState_request st in
552 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
554 then Web.parseQueryParam . Text.decodeUtf8 <$> v
556 case sequence vals of
557 Left err -> Left $ Fail st [ServerErrorQuery err]
558 Right vs -> Right $ Right $ Right ($ vs)
560 -- ** Type 'ServerErrorHeader'
561 data ServerErrorHeader = ServerErrorHeader
563 instance HTTP_Header Server where
564 header n = Server $ do
566 lift $ ExceptT $ ExceptT $ return $
567 let hs = Wai.requestHeaders $ serverState_request st in
568 case List.lookup n hs of
569 Nothing -> Left $ Fail st [ServerErrorHeader]
570 Just v -> Right $ Right ($ v)
572 -- ** Type 'ServerErrorBasicAuth'
573 data ServerErrorBasicAuth =
574 ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
577 -- ** Class 'ServerBasicAuth'
578 class ServerBasicAuth a where
584 data Dict a where Dict :: a => Dict a
586 -- | WARNING: current implementation of Basic Access Authentication
587 -- is not immune to certian kinds of timing attacks.
588 -- Decoding payloads does not take a fixed amount of time.
589 instance HTTP_BasicAuth Server where
590 type BasicAuthConstraint Server = ServerBasicAuth
591 type BasicAuthArgs Server a k = a -> k
592 basicAuth' realm = Server $ do
594 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
595 case decodeAuthorization $ serverState_request st of
596 Nothing -> err BasicAuth_BadPassword
597 Just (user, pass) -> do
598 liftIO (serverBasicAuth user pass) >>= \case
599 BasicAuth_BadPassword -> err BasicAuth_BadPassword
600 BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser
601 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
602 BasicAuth_Authorized a -> return ($ a)
604 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
605 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
606 decodeAuthorization req = do
607 hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
608 let (basic, rest) = BS.break Word8.isSpace hAuthorization
609 guard (BS.map Word8.toLower basic == "basic")
610 let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
611 let (user, colon_pass) = BS.break (== Word8._colon) decoded
612 (_, pass) <- BS.uncons colon_pass
613 return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
615 -- ** Type 'ServerErrorBody'
616 newtype ServerErrorBody = ServerErrorBody String
619 -- *** Type 'ServerBodyArg'
620 newtype ServerBodyArg a (ts::[*]) = ServerBodyArg a
622 instance HTTP_Body Server where
623 type BodyArg Server = ServerBodyArg
624 type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
627 BodyConstraint repr a ts =>
629 repr (BodyArg repr a ts -> k) k
632 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
633 let hs = Wai.requestHeaders $ serverState_request st
635 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
636 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
637 fromMaybe "application/octet-stream" $
638 List.lookup HTTP.hContentType hs
639 case matchContent @ts @(MimeDecodable a) reqContentType of
640 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
641 Just (MimeType mt) -> do
642 bodyBS <- liftIO $ Wai.requestBody $ serverState_request st
643 return $ Right $ Right $ Right $
644 -- NOTE: delay unSerialize after all checks
645 case mimeDecode mt $ BSL.fromStrict bodyBS of
646 Left err -> Left $ Fail st [ServerErrorBody err]
647 Right a -> Right ($ ServerBodyArg a)
649 -- ** Type 'ServerResponse'
650 newtype ServerResponse = ServerResponse
651 ( -- the request made to the server
653 -- the continuation for the server to respond
654 (Wai.Response -> IO Wai.ResponseReceived) ->
655 IO Wai.ResponseReceived
657 instance Show ServerResponse where
658 show _ = "ServerResponse"
660 -- *** Type 'ServerRespond'
661 newtype ServerRespond a (ts::[*]) = ServerRespond
663 HTTP.ResponseHeaders ->
666 instance HTTP_Response Server where
667 type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
668 type ResponseArgs Server a ts = ServerRespond a ts -> ServerResponse
669 type Response Server a ts = ServerResponse
672 ResponseConstraint repr a ts =>
675 repr (ResponseArgs repr a ts)
677 response expMethod = Server $ do
679 { serverState_offset = o
680 , serverState_request = req
683 -- Check the path has been fully consumed
684 unless (List.null $ Wai.pathInfo req) $
685 MC.throw $ Fail st [ServerErrorPath o "path is longer"]
688 let reqMethod = Wai.requestMethod $ serverState_request st
689 unless (reqMethod == expMethod
690 || reqMethod == HTTP.methodHead
691 && expMethod == HTTP.methodGet) $
692 MC.throw $ Fail st [ServerErrorMethod]
694 -- Check the Accept header
695 let reqHeaders = Wai.requestHeaders $ serverState_request st
696 MimeType reqAccept <- do
697 case List.lookup HTTP.hAccept reqHeaders of
698 Nothing -> return $ List.head $ listMimeTypes @ts @(MimeEncodable a)
700 case matchAccept @ts @(MimeEncodable a) h of
701 Nothing -> MC.throw $ Fail st [ServerErrorAccept (listMediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
704 case Media.parseAccept h of
705 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaType expAccept) (Just (Left h))]
707 | mediaType expAccept`Media.matches`gotAccept -> return expAccept
708 -- FIXME: return gotAccept, maybe with GADTs
709 | otherwise -> MC.throw $ Fail st
710 [ServerErrorAccept (mediaType expAccept) (Just (Right gotAccept))]
714 return ($ ServerRespond $ \s hs a ->
716 ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
717 (if reqMethod == HTTP.methodHead
719 else mimeEncode reqAccept a))
722 status200 :: HTTP.Status
723 status200 = HTTP.mkStatus 200 "Success"
724 status400 :: HTTP.Status
725 status400 = HTTP.mkStatus 400 "Bad Request"
726 status401 :: HTTP.Status
727 status401 = HTTP.mkStatus 401 "Unauthorized"
728 status403 :: HTTP.Status
729 status403 = HTTP.mkStatus 403 "Forbidden"
730 status404 :: HTTP.Status
731 status404 = HTTP.mkStatus 404 "Not Found"
732 status405 :: HTTP.Status
733 status405 = HTTP.mkStatus 405 "Method Not Allowed"
734 status406 :: HTTP.Status
735 status406 = HTTP.mkStatus 406 "Not Acceptable"
736 status415 :: HTTP.Status
737 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
738 status500 :: HTTP.Status
739 status500 = HTTP.mkStatus 500 "Server Error"
742 liftIO :: MC.MonadExec IO m => IO a -> m a
744 {-# INLINE liftIO #-}