1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE InstanceSigs #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE TypeFamilies #-}
7 module Symantic.HTTP.Server where
9 import Control.Arrow (first)
10 import Control.Monad (Monad(..), unless, sequence)
11 import Control.Monad.Trans.Class (MonadTrans(..))
12 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
14 import Data.Either (Either(..))
15 import Data.Eq (Eq(..))
16 import Data.Function (($), (.), id)
17 import Data.Functor (Functor, (<$>))
19 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
20 import Data.Proxy (Proxy(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.String (String, IsString(..))
23 import Data.Text (Text)
26 import Text.Show (Show(..))
27 import qualified Control.Monad.Classes as MC
28 import qualified Control.Monad.Trans.State as S
29 import qualified Data.ByteString as BS
30 import qualified Data.ByteString.Lazy as BSL
31 import qualified Data.List as List
32 import qualified Data.Text.Encoding as Text
33 import qualified Network.HTTP.Media as Media
34 import qualified Network.HTTP.Types as HTTP
35 import qualified Network.Wai as Wai
36 import qualified Web.HttpApiData as Web
38 import Symantic.HTTP.API
39 import Symantic.HTTP.Mime
42 -- | @Server f k@ is a recipe to produce an 'Wai.Application'
43 -- from handlers 'f' (one per number of alternative routes).
45 -- 'Server' is analogous to a scanf using a format customized for HTTP routing.
47 -- The multiple monad transformers are there to prioritize the errors
48 -- according to the type of check raising them,
49 -- instead of the order of the combinators within an actual API specification.
50 newtype Server f k = Server { unServer ::
52 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
53 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
54 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
55 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
56 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
57 (-- TODO: ServerCheckT [ServerErrorAuth] -- 3rd check, 401 error
58 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
59 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
64 -- | @'server' api handlers@ returns a 'Wai.Application'
65 -- ready to be given to @Warp.run 80@.
67 Server handlers ServerResponse ->
70 server (Server api) handlers rq re = do
71 lrPath <- runServerChecks api $ ServerState 0 rq
73 Left err -> respondError status404 err
76 Left err -> respondError status405 err
79 Left err -> respondError status406 err
80 Right lrContentType ->
82 Left err -> respondError status415 err
85 Left err -> respondError status400 err
88 Left err -> respondError status400 err
91 Left err -> respondError status400 err
93 let ServerResponse app = a2k handlers in
96 respondError :: Show err => HTTP.Status -> err -> IO Wai.ResponseReceived
98 -- Trace.trace (show err) $
99 re $ Wai.responseLBS st
100 [(HTTP.hContentType, Media.renderHeader $ mimeType mimePlainText)]
101 (fromString $ show err) -- TODO: see what to return in the body
104 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
106 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 IO))))))) a ->
107 ServerState -> IO (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState))))))))
108 runServerChecks s st =
118 -- ** Type 'ServerCheckT'
119 type ServerCheckT e = ExceptT (Fail e)
121 -- *** Type 'RouteResult'
122 type RouteResult e = Either (Fail e)
126 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
127 | FailFatal !ServerState !e -- ^ Don't try other paths.
129 failState :: Fail e -> ServerState
130 failState (Fail st _) = st
131 failState (FailFatal st _) = st
132 instance Semigroup e => Semigroup (Fail e) where
133 Fail _ x <> Fail st y = Fail st (x<>y)
134 FailFatal _ x <> Fail st y = FailFatal st (x<>y)
135 Fail _ x <> FailFatal st y = FailFatal st (x<>y)
136 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
138 -- ** Type 'ServerState'
139 data ServerState = ServerState
140 { serverState_offset :: Offset -- TODO: remove
141 , serverState_request :: Wai.Request
145 instance Show ServerState where
146 show _ = "ServerState"
147 instance Cat Server where
151 repr a b -> repr b c -> repr a c
152 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
153 -- And if so, fail with y instead of x.
155 -- This long spaghetti code may probably be avoided
156 -- with a more sophisticated 'Server' using a binary tree
157 -- instead of nested 'Either's, so that its 'Monad' instance
158 -- would do the right thing. But to my mind,
159 -- with the very few priorities of checks currently needed,
160 -- this is not worth the cognitive pain to design it.
161 -- A copy/paste/adapt will do for now.
162 Server x <.> Server y = Server $
164 xPath <- liftIO $ runServerChecks x st
166 Left xe -> MC.throw xe
170 yPath <- liftIO $ runServerChecks y (failState xe)
172 Left ye -> MC.throw ye
173 Right _yMethod -> MC.throw xe
177 yPath <- liftIO $ runServerChecks y (failState xe)
179 Left ye -> MC.throw ye
182 Left ye -> MC.throw ye
183 Right _yAccept -> MC.throw xe
184 Right xContentType ->
187 yPath <- liftIO $ runServerChecks y (failState xe)
189 Left ye -> MC.throw ye
192 Left ye -> MC.throw ye
195 Left ye -> MC.throw ye
196 Right _yQuery -> MC.throw xe
200 yPath <- liftIO $ runServerChecks y (failState xe)
202 Left ye -> MC.throw ye
205 Left ye -> MC.throw ye
208 Left ye -> MC.throw ye
211 Left ye -> MC.throw ye
212 Right _yHeader -> MC.throw xe
216 yPath <- liftIO $ runServerChecks y (failState xe)
218 Left ye -> MC.throw ye
221 Left ye -> MC.throw ye
224 Left ye -> MC.throw ye
227 Left ye -> MC.throw ye
230 Left ye -> MC.throw ye
231 Right _yBody -> MC.throw xe
235 yPath <- liftIO $ runServerChecks y (failState xe)
237 Left ye -> MC.throw ye
240 Left ye -> MC.throw ye
243 Left ye -> MC.throw ye
246 Left ye -> MC.throw ye
249 Left ye -> MC.throw ye
250 Right _yBody -> MC.throw xe
252 (first (. a2b)) <$> S.runStateT y st'
253 instance Alt Server where
254 Server x <!> Server y = Server $
256 xPath <- liftIO $ runServerChecks x st
257 yPath <- liftIO $ runServerChecks y st
258 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
260 Left xe | FailFatal{} <- xe -> MC.throw xe
263 Left ye -> MC.throw (xe<>ye)
265 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
266 return $ Right yMethod
269 Left xe | FailFatal{} <- xe -> MC.throw xe
272 Left _ye -> MC.throw xe
275 Left ye -> MC.throw (xe<>ye)
277 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
278 return $ Right $ yAccept
281 Left xe | FailFatal{} <- xe -> MC.throw xe
284 Left _ye -> MC.throw xe
287 Left _ye -> MC.throw xe
290 Left ye -> MC.throw (xe<>ye)
291 Right yContentType ->
292 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
293 return $ Right yContentType
294 Right xContentType ->
296 Left xe | FailFatal{} <- xe -> MC.throw xe
299 Left _ye -> MC.throw xe
302 Left _ye -> MC.throw xe
305 Left _ye -> MC.throw xe
306 Right yContentType ->
308 Left ye -> MC.throw (xe<>ye)
310 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
311 return $ Right yQuery
314 Left xe | FailFatal{} <- xe -> MC.throw xe
317 Left _ye -> MC.throw xe
320 Left _ye -> MC.throw xe
323 Left _ye -> MC.throw xe
324 Right yContentType ->
326 Left _ye -> MC.throw xe
329 Left ye -> MC.throw (xe<>ye)
331 fy $ ExceptT $ ExceptT $ ExceptT $
332 return $ Right yHeader
335 Left xe | FailFatal{} <- xe -> MC.throw xe
338 Left _ye -> MC.throw xe
341 Left _ye -> MC.throw xe
344 Left _ye -> MC.throw xe
345 Right yContentType ->
347 Left _ye -> MC.throw xe
350 Left _ye -> MC.throw xe
353 Left ye -> MC.throw (xe<>ye)
355 fy $ ExceptT $ ExceptT $
359 Left xe | FailFatal{} <- xe -> MC.throw xe
362 Left _ye -> MC.throw xe
365 Left _ye -> MC.throw xe
368 Left _ye -> MC.throw xe
369 Right yContentType ->
371 Left _ye -> MC.throw xe
374 Left _ye -> MC.throw xe
377 Left _ye -> MC.throw xe
380 Left ye -> MC.throw (xe<>ye)
385 return $ first (\a2k (a:!:_b) -> a2k a) xr
387 instance Pro Server where
388 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
390 -- ** Type 'ServerErrorPath'
391 data ServerErrorPath = ServerErrorPath Offset Text
393 instance HTTP_Path Server where
394 segment expSegment = Server $ do
396 { serverState_offset = o
397 , serverState_request = req
399 case Wai.pathInfo req of
400 [] -> MC.throw $ Fail st [ServerErrorPath o "segment: empty"]
401 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
403 | curr /= expSegment ->
404 MC.throw $ Fail st [ServerErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
407 { serverState_offset = o+1
408 , serverState_request = req{ Wai.pathInfo = next }
411 capture' :: forall a k.
412 Web.FromHttpApiData a =>
413 Web.ToHttpApiData a =>
414 Name -> Server (a -> k) k
415 capture' name = Server $ do
417 { serverState_offset = o
418 , serverState_request = req
420 case Wai.pathInfo req of
421 [] -> MC.throw $ Fail st [ServerErrorPath o "empty"]
422 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
424 case Web.parseUrlPiece curr of
425 Left err -> MC.throw $ Fail st [ServerErrorPath o $ "capture: "<>fromString name<>": "<>err]
428 { serverState_offset = o+1
429 , serverState_request = req{ Wai.pathInfo = next }
432 captureAll = Server $ do
433 req <- S.gets serverState_request
434 return ($ Wai.pathInfo req)
436 -- ** Type 'ServerErrorMethod'
437 data ServerErrorMethod = ServerErrorMethod
440 -- | TODO: add its own error?
441 instance HTTP_Version Server where
442 version exp = Server $ do
444 let got = Wai.httpVersion $ serverState_request st
447 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
449 -- ** Type 'ServerErrorAccept'
450 data ServerErrorAccept =
453 (Maybe (Either BS.ByteString MediaType))
456 -- ** Type 'ServerErrorContentType'
457 data ServerErrorContentType = ServerErrorContentType
459 instance HTTP_ContentType Server where
460 contentType exp = Server $ do
462 let hs = Wai.requestHeaders $ serverState_request st
464 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
465 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
466 fromMaybe "application/octet-stream" $
467 List.lookup HTTP.hContentType hs
468 case Media.mapContentMedia [(mimeType exp, ())] got of
469 Nothing -> MC.throw $ Fail st [ServerErrorContentType]
470 Just () -> return id -- TODO: mimeUnserialize
472 -- ** Type 'ServerErrorQuery'
473 newtype ServerErrorQuery = ServerErrorQuery Text
475 instance HTTP_Query Server where
476 queryParams' name = Server $ do
478 lift $ ExceptT $ ExceptT $ ExceptT $ return $
479 let qs = Wai.queryString $ serverState_request st in
480 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
482 then Web.parseQueryParam . Text.decodeUtf8 <$> v
484 case sequence vals of
485 Left err -> Left $ Fail st [ServerErrorQuery err]
486 Right vs -> Right $ Right $ Right ($ vs)
488 -- ** Type 'ServerErrorHeader'
489 data ServerErrorHeader = ServerErrorHeader
491 instance HTTP_Header Server where
492 header n = Server $ do
494 lift $ ExceptT $ ExceptT $ return $
495 let hs = Wai.requestHeaders $ serverState_request st in
496 case List.lookup n hs of
497 Nothing -> Left $ Fail st [ServerErrorHeader]
498 Just v -> Right $ Right ($ v)
500 -- ** Type 'ServerErrorBody'
501 newtype ServerErrorBody = ServerErrorBody String
504 -- *** Type 'ServerBodyArg'
505 newtype ServerBodyArg mt a = ServerBodyArg a
507 instance HTTP_Body Server where
508 type BodyArg Server = ServerBodyArg
511 MimeUnserialize a mt =>
512 MimeSerialize a mt =>
514 repr (BodyArg repr mt a -> k) k
517 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
518 let hs = Wai.requestHeaders $ serverState_request st
519 let expContentType = (Proxy::Proxy mt)
521 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
522 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
523 fromMaybe "application/octet-stream" $
524 List.lookup HTTP.hContentType hs
525 case Media.mapContentMedia
526 [ ( mimeType expContentType
527 , mimeUnserialize expContentType )
529 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
530 Just unSerialize -> do
531 bodyBS <- liftIO $ Wai.requestBody $ serverState_request st
532 return $ Right $ Right $ Right $
533 -- NOTE: delay unSerialize after all checks
534 case unSerialize $ BSL.fromStrict bodyBS of
535 Left err -> Left $ Fail st [ServerErrorBody err]
536 Right a -> Right ($ ServerBodyArg a)
538 -- ** Type 'ServerResponse'
539 newtype ServerResponse = ServerResponse
540 ( -- the request made to the server
542 -- the continuation for the server to respond
543 (Wai.Response -> IO Wai.ResponseReceived) ->
544 IO Wai.ResponseReceived
546 instance Show ServerResponse where
547 show _ = "ServerResponse"
549 -- *** Type 'ServerResponseArg'
550 newtype ServerResponseArg mt a =
553 HTTP.ResponseHeaders ->
556 instance HTTP_Response Server where
557 type Response Server = ServerResponse
558 type ResponseArg Server = ServerResponseArg
561 MimeUnserialize a mt =>
562 MimeSerialize a mt =>
566 repr (ResponseArg repr mt a -> k) k
567 response expMethod = Server $ do
569 { serverState_offset = o
570 , serverState_request = req
573 -- Check the path has been fully consumed
574 unless (List.null $ Wai.pathInfo req) $
575 MC.throw $ Fail st [ServerErrorPath o "path is longer"]
578 let reqMethod = Wai.requestMethod $ serverState_request st
579 unless (reqMethod == expMethod
580 || reqMethod == HTTP.methodHead
581 && expMethod == HTTP.methodGet) $
582 MC.throw $ Fail st [ServerErrorMethod]
584 -- Check the Accept header
585 let reqHeaders = Wai.requestHeaders $ serverState_request st
586 let expAccept = (Proxy::Proxy mt)
588 case List.lookup HTTP.hAccept reqHeaders of
589 Nothing -> return expAccept
591 case Media.parseAccept h of
592 Nothing -> MC.throw $ Fail st
593 [ServerErrorAccept (mimeType expAccept) (Just (Left h))]
595 | mimeType expAccept`Media.matches`gotAccept -> return expAccept
596 -- FIXME: return gotAccept, maybe with GADTs
597 | otherwise -> MC.throw $ Fail st
598 [ServerErrorAccept (mimeType expAccept) (Just (Right gotAccept))]
601 return ($ ServerResponseArg $ \s hs a ->
603 ((HTTP.hContentType, Media.renderHeader $ mimeType reqAccept):hs)
604 (if reqMethod == HTTP.methodHead
606 else mimeSerialize reqAccept a))
609 liftIO :: MC.MonadExec IO m => IO a -> m a
611 {-# INLINE liftIO #-}