{-# LANGUAGE GADTs #-} -- for 'Router' {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -- for 'Tree' {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -- for nested type family application, -- eg. in 'BodyStreamConstraint' {-# OPTIONS_GHC -fno-warn-orphans #-} -- | See -- for an example of how to use this module. module Symantic.HTTP.Server where import Control.Applicative (Applicative(..)) import Control.Arrow (first) import Control.Monad (Monad(..), unless, sequence, guard, (=<<)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Function (($), (.), id, const) import Data.Functor (Functor(..), (<$>)) import Data.Int (Int) import Data.Kind (Type) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Data.Text (Text) import Prelude (undefined) -- for factorizing captures import System.IO (IO) import Text.Show (Show(..)) import qualified Control.Monad.Classes as MC import qualified Control.Monad.Trans.Cont as C import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Strict as W import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS64 import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Word8 as Word8 import qualified Network.HTTP.Media as Media import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types.Header as HTTP import qualified Network.Wai as Wai import qualified Web.HttpApiData as Web import Symantic.HTTP -- * Type 'Server' -- | (@'Server' handlers k@) is a recipe to produce an 'Wai.Application' -- from given ('handlers') (one per number of alternative routes), -- separated by (':!:'). -- -- 'Server' is analogous to a scanf using the API as a format customized for HTTP routing. -- -- The multiple 'ServerCheckT' monad transformers are there -- to prioritize the errors according to the type of check raising them, -- instead of the order of the combinators within an actual API specification. newtype Server handlers k = Server { unServer :: S.StateT ServerState (ServerCheckT [ServerErrorBody] -- 8th check, 400 error (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 or 403 error (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error (ServerCheckT [ServerErrorPath] -- 1st check, 404 error IO)))))))) (handlers -> k) } -- | (@'server' api handlers@) returns an 'Wai.Application' -- ready to be given to @Warp.run 80@. server :: Router Server handlers (Response Server) -> handlers -> Wai.Application server api handlers rq re = do lrPath <- runServerChecks (unServer $ unTrans $ router api) $ ServerState rq case lrPath of Left err -> respondError HTTP.status404 [] err Right lrMethod -> case lrMethod of Left err -> respondError HTTP.status405 [] err Right lrBasicAuth -> case lrBasicAuth of Left err -> case failError err of [] -> respondError HTTP.status500 [] err ServerErrorBasicAuth realm ba:_ -> case ba of BasicAuth_Unauthorized -> respondError HTTP.status403 [] err _ -> respondError HTTP.status401 [ ( HTTP.hWWWAuthenticate , "Basic realm=\""<>Web.toHeader realm<>"\"" ) ] err Right lrAccept -> case lrAccept of Left err -> respondError HTTP.status406 [] err Right lrContentType -> case lrContentType of Left err -> respondError HTTP.status415 [] err Right lrQuery -> case lrQuery of Left err -> respondError HTTP.status400 [] err Right lrHeader -> case lrHeader of Left err -> respondError HTTP.status400 [] err Right lrBody -> case lrBody of Left err -> respondError HTTP.status400 [] err Right (app, _st) -> app handlers rq re where respondError :: Show err => HTTP.Status -> [(HTTP.HeaderName, HeaderValue)] -> err -> IO Wai.ResponseReceived respondError st hs err = -- Trace.trace (show err) $ re $ Wai.responseLBS st ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText) : hs ) (fromString $ show err) -- TODO: see what to return in the body -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors. runServerChecks :: S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a -> ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState))))))))) runServerChecks s st = runExceptT $ runExceptT $ runExceptT $ runExceptT $ runExceptT $ runExceptT $ runExceptT $ runExceptT $ S.runStateT s st -- ** Type 'ServerCheckT' type ServerCheckT e = ExceptT (Fail e) -- *** Type 'RouteResult' type RouteResult e = Either (Fail e) -- *** Type 'Fail' data Fail e = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406. | FailFatal !ServerState !e -- ^ Don't try other paths. deriving (Show) failState :: Fail e -> ServerState failState (Fail st _) = st failState (FailFatal st _) = st failError :: Fail e -> e failError (Fail _st e) = e failError (FailFatal _st e) = e instance Semigroup e => Semigroup (Fail e) where Fail _ x <> Fail st y = Fail st (x<>y) FailFatal _ x <> Fail st y = FailFatal st (x<>y) Fail _ x <> FailFatal st y = FailFatal st (x<>y) FailFatal _ x <> FailFatal st y = FailFatal st (x<>y) -- ** Type 'ServerState' newtype ServerState = ServerState { serverState_request :: Wai.Request } -- deriving (Show) instance Show ServerState where show _ = "ServerState" instance Cat Server where (<.>) :: forall a b c repr. repr ~ Server => repr a b -> repr b c -> repr a c -- NOTE: if x fails, run y to see if it fails on a more prioritized check. -- And if so, fail with y instead of x. -- -- This long spaghetti code may probably be avoided -- with a more sophisticated 'Server' using a binary tree -- instead of nested 'Either's, so that its 'Monad' instance -- would do the right thing. But to my mind, -- with the very few priorities of checks currently needed, -- this is not worth the cognitive pain to design it. -- Some copying/pasting/adapting will do for now. Server x <.> Server y = Server $ S.StateT $ \st -> do xPath <- MC.exec @IO $ runServerChecks x st case xPath of Left xe -> MC.throw xe Right xMethod -> case xMethod of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right _yMethod -> MC.throw xe Right xBasicAuth -> case xBasicAuth of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right _yBasicAuth -> MC.throw xe Right xAccept -> case xAccept of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw ye Right _yAccept -> MC.throw xe Right xContentType -> case xContentType of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw ye Right yAccept -> case yAccept of Left ye -> MC.throw ye Right _yQuery -> MC.throw xe Right xQuery -> case xQuery of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw ye Right yAccept -> case yAccept of Left ye -> MC.throw ye Right yQuery -> case yQuery of Left ye -> MC.throw ye Right _yHeader -> MC.throw xe Right xHeader -> case xHeader of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw ye Right yAccept -> case yAccept of Left ye -> MC.throw ye Right yQuery -> case yQuery of Left ye -> MC.throw ye Right yHeader -> case yHeader of Left ye -> MC.throw ye Right _yBody -> MC.throw xe Right xBody -> case xBody of Left xe -> do yPath <- MC.exec @IO $ runServerChecks y (failState xe) case yPath of Left ye -> MC.throw ye Right yMethod -> case yMethod of Left ye -> MC.throw ye Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw ye Right yAccept -> case yAccept of Left ye -> MC.throw ye Right yQuery -> case yQuery of Left ye -> MC.throw ye Right yHeader -> case yHeader of Left ye -> MC.throw ye Right _yBody -> MC.throw xe Right (a2b, st') -> first (. a2b) <$> S.runStateT y st' instance Alt Server where -- () :: repr a k -> repr b k -> repr (a:!:b) k Server x Server y = Server $ S.StateT $ \st -> do xPath <- MC.exec @IO $ runServerChecks x st let fy = (first (\b2k (_a:!:b) -> b2k b) <$>) case xPath of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left ye -> MC.throw (xe<>ye) Right yMethod -> fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ return $ Right yMethod Right xMethod -> case xMethod of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left ye -> MC.throw (xe<>ye) Right yBasicAuth -> fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ return $ Right $ yBasicAuth Right xBasicAuth -> case xBasicAuth of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left ye -> MC.throw (xe<>ye) Right yAccept -> fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ return $ Right yAccept Right xAccept -> case xAccept of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left _ye -> MC.throw xe Right yAccept -> case yAccept of Left ye -> MC.throw (xe<>ye) Right yContentType -> fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ return $ Right yContentType Right xContentType -> case xContentType of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left _ye -> MC.throw xe Right yAccept -> case yAccept of Left _ye -> MC.throw xe Right yContentType -> case yContentType of Left ye -> MC.throw (xe<>ye) Right yQuery -> fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ return $ Right yQuery Right xQuery -> case xQuery of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left _ye -> MC.throw xe Right yAccept -> case yAccept of Left _ye -> MC.throw xe Right yContentType -> case yContentType of Left _ye -> MC.throw xe Right yQuery -> case yQuery of Left ye -> MC.throw (xe<>ye) Right yHeader -> fy $ ExceptT $ ExceptT $ ExceptT $ return $ Right yHeader Right xHeader -> case xHeader of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left _ye -> MC.throw xe Right yAccept -> case yAccept of Left _ye -> MC.throw xe Right yContentType -> case yContentType of Left _ye -> MC.throw xe Right yQuery -> case yQuery of Left _ye -> MC.throw xe Right yHeader -> case yHeader of Left ye -> MC.throw (xe<>ye) Right yBody -> fy $ ExceptT $ ExceptT $ return $ Right yBody Right xBody -> case xBody of Left xe | FailFatal{} <- xe -> MC.throw xe | otherwise -> do yPath <- MC.exec @IO $ runServerChecks y st case yPath of Left _ye -> MC.throw xe Right yMethod -> case yMethod of Left _ye -> MC.throw xe Right yBasicAuth -> case yBasicAuth of Left _ye -> MC.throw xe Right yAccept -> case yAccept of Left _ye -> MC.throw xe Right yContentType -> case yContentType of Left _ye -> MC.throw xe Right yQuery -> case yQuery of Left _ye -> MC.throw xe Right yHeader -> case yHeader of Left _ye -> MC.throw xe Right yBody -> case yBody of Left ye -> MC.throw (xe<>ye) Right yr -> fy $ ExceptT $ return $ Right yr Right xr -> return $ first (\a2k (a:!:_b) -> a2k a) xr instance Pro Server where dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r -- ** Type 'ServerErrorPath' newtype ServerErrorPath = ServerErrorPath Text deriving (Eq, Show) instance HTTP_Path Server where type PathConstraint Server a = Web.FromHttpApiData a segment expSegment = Server $ do st@ServerState { serverState_request = req } <- S.get case Wai.pathInfo req of [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"] [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"] curr:next | curr /= expSegment -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr] | otherwise -> do S.put st { serverState_request = req{ Wai.pathInfo = next } } return id capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k capture' name = Server $ do st@ServerState { serverState_request = req } <- S.get case Wai.pathInfo req of [] -> MC.throw $ Fail st [ServerErrorPath "empty"] [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"] curr:next -> case Web.parseUrlPiece curr of Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err] Right a -> do S.put st { serverState_request = req{ Wai.pathInfo = next } } return ($ a) captureAll = Server $ do req <- S.gets serverState_request return ($ Wai.pathInfo req) -- ** Type 'ServerErrorMethod' data ServerErrorMethod = ServerErrorMethod deriving (Eq, Show) -- | TODO: add its own error? instance HTTP_Version Server where version exp = Server $ do st <- S.get let got = Wai.httpVersion $ serverState_request st if got == exp then return id else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion -- ** Type 'ServerErrorAccept' data ServerErrorAccept = ServerErrorAccept MediaTypes (Maybe (Either BS.ByteString MediaType)) deriving (Eq, Show) -- ** Type 'ServerErrorContentType' data ServerErrorContentType = ServerErrorContentType deriving (Eq, Show) -- ** Type 'ServerErrorQuery' newtype ServerErrorQuery = ServerErrorQuery Text deriving (Show) instance HTTP_Query Server where type QueryConstraint Server a = Web.FromHttpApiData a queryParams' name = Server $ do st <- S.get lift $ ExceptT $ ExceptT $ ExceptT $ return $ let qs = Wai.queryString $ serverState_request st in let vals = catMaybes $ (<$> qs) $ \(n,v) -> if n == name then Web.parseQueryParam . Text.decodeUtf8 <$> v else Nothing in case sequence vals of Left err -> Left $ Fail st [ServerErrorQuery err] Right vs -> Right $ Right $ Right ($ vs) -- ** Type 'ServerErrorHeader' data ServerErrorHeader = ServerErrorHeader deriving (Eq, Show) instance HTTP_Header Server where header n = Server $ do st <- S.get lift $ ExceptT $ ExceptT $ return $ let hs = Wai.requestHeaders $ serverState_request st in case List.lookup n hs of Nothing -> Left $ Fail st [ServerErrorHeader] Just v -> Right $ Right ($ v) -- ** Type 'ServerErrorBasicAuth' data ServerErrorBasicAuth = ServerErrorBasicAuth BasicAuthRealm (BasicAuth ()) deriving (Show) -- ** Class 'ServerBasicAuth' -- | Custom 'BasicAuth' check. class ServerBasicAuth a where serverBasicAuth :: BasicAuthUser -> BasicAuthPass -> IO (BasicAuth a) -- | WARNING: current implementation of Basic Access Authentication -- is not immune to certain kinds of timing attacks. -- Decoding payloads does not take a fixed amount of time. instance HTTP_BasicAuth Server where type BasicAuthConstraint Server a = ServerBasicAuth a type BasicAuthArgs Server a k = a -> k basicAuth' realm = Server $ do st <- S.get let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e] case decodeAuthorization $ serverState_request st of Nothing -> err BasicAuth_BadPassword Just (user, pass) -> do MC.exec @IO (serverBasicAuth user pass) >>= \case BasicAuth_BadPassword -> err BasicAuth_BadPassword BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser BasicAuth_Unauthorized -> err BasicAuth_Unauthorized BasicAuth_Authorized u -> return ($ u) where -- | Find and decode an 'Authorization' header from the request as a Basic Auth decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass) decodeAuthorization req = do hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req let (basic, rest) = BS.break Word8.isSpace hAuthorization guard (BS.map Word8.toLower basic == "basic") let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest) let (user, colon_pass) = BS.break (== Word8._colon) decoded (_, pass) <- BS.uncons colon_pass return (Text.decodeUtf8 user, Text.decodeUtf8 pass) -- ** Type 'ServerErrorBody' newtype ServerErrorBody = ServerErrorBody String deriving (Eq, Show) -- *** Type 'ServerBodyArg' newtype ServerBodyArg (ts::[Type]) a = ServerBodyArg a instance HTTP_Body Server where type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a) type BodyArg Server a ts = ServerBodyArg ts a body' :: forall a ts k repr. BodyConstraint repr a ts => repr ~ Server => repr (BodyArg repr a ts -> k) k body'= Server $ do st <- S.get lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do let hs = Wai.requestHeaders $ serverState_request st let reqContentType = -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime fromMaybe "application/octet-stream" $ List.lookup HTTP.hContentType hs case matchContent @ts @(MimeDecodable a) reqContentType of Nothing -> return $ Left $ Fail st [ServerErrorContentType] Just (MimeType mt) -> do bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st return $ Right $ Right $ Right $ -- NOTE: delay 'mimeDecode' after all checks case mimeDecode mt $ BSL.fromStrict bodyBS of Left err -> Left $ Fail st [ServerErrorBody err] Right a -> Right ($ ServerBodyArg a) -- *** Type 'ServerBodyStreamArg' newtype ServerBodyStreamArg as (ts::[Type]) framing = ServerBodyStreamArg as instance HTTP_BodyStream Server where type BodyStreamConstraint Server as ts framing = ( FramingDecode framing as , MC.MonadExec IO (FramingMonad as) , MimeTypes ts (MimeDecodable (FramingYield as)) ) type BodyStreamArg Server as ts framing = ServerBodyStreamArg as ts framing bodyStream' :: forall as ts framing k repr. BodyStreamConstraint repr as ts framing => repr ~ Server => repr (BodyStreamArg repr as ts framing -> k) k bodyStream'= Server $ do st <- S.get lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do let hs = Wai.requestHeaders $ serverState_request st let reqContentType = -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime fromMaybe "application/octet-stream" $ List.lookup HTTP.hContentType hs case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of Nothing -> return $ Left $ Fail st [ServerErrorContentType] Just (MimeType mt) -> do let bodyBS = Wai.requestBody $ serverState_request st return $ Right $ Right $ Right $ Right ($ ServerBodyStreamArg $ framingDecode (Proxy @framing) (mimeDecode mt) $ MC.exec @IO bodyBS ) -- * Type 'ServerResponse' -- | A continuation for 'server''s users to respond. -- -- This newtype has two usesĀ : -- -- * Carrying the 'ts' type variable to 'server'. -- * Providing a 'return' for the simple response case -- of 'HTTP.status200' and no extra headers. newtype ServerRes (ts::[Type]) m a = ServerResponse { unServerResponse :: m a } deriving (Functor, Applicative, Monad) type ServerResponse ts m = ServerRes ts (R.ReaderT Wai.Request (W.WriterT HTTP.ResponseHeaders (W.WriterT HTTP.Status (C.ContT Wai.Response m)))) instance MonadTrans (ServerRes ts) where lift = ServerResponse -- | All supported effects are handled by nested 'Monad's. type instance MC.CanDo (ServerResponse ts m) eff = 'False type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False instance HTTP_Response Server where type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a) type ResponseArgs Server a ts = ServerResponse ts IO a type Response Server = Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived response :: forall a ts repr. ResponseConstraint repr a ts => repr ~ Server => HTTP.Method -> repr (ResponseArgs repr a ts) (Response repr) response expMethod = Server $ do st@ServerState { serverState_request = req } <- S.get -- Check the path has been fully consumed unless (List.null $ Wai.pathInfo req) $ MC.throw $ Fail st [ServerErrorPath "path is longer"] -- Check the method let reqMethod = Wai.requestMethod $ serverState_request st unless (reqMethod == expMethod || reqMethod == HTTP.methodHead && expMethod == HTTP.methodGet) $ MC.throw $ Fail st [ServerErrorMethod] -- Check the Accept header let reqHeaders = Wai.requestHeaders $ serverState_request st MimeType reqAccept <- do case List.lookup HTTP.hAccept reqHeaders of Nothing -> return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a) Just h -> case matchAccept @ts @(MimeEncodable a) h of Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))] Just mt -> return mt return $ \(ServerResponse k) rq re -> re =<< do C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) -> return{-IO-} $ Wai.responseLBS sta ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs) (if reqMethod == HTTP.methodHead then "" else mimeEncode reqAccept a) -- * Type 'ServerResponseStream' -- -- This newtype has three usesĀ : -- -- * Carrying the 'framing' type variable to 'server'. -- * Carrying the 'ts' type variable to 'server'. -- * Providing a 'return' for the simple response case -- of 'HTTP.status200' and no extra headers. newtype ServerResStream framing (ts::[Type]) m as = ServerResponseStream { unServerResponseStream :: m as } deriving (Functor, Applicative, Monad) instance MonadTrans (ServerResStream framing ts) where lift = ServerResponseStream type ServerResponseStream framing ts m = ServerResStream framing ts (R.ReaderT Wai.Request (W.WriterT HTTP.ResponseHeaders (W.WriterT HTTP.Status (C.ContT Wai.Response m)))) -- | All supported effects are handled by nested 'Monad's. type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False instance HTTP_ResponseStream Server where type ResponseStreamConstraint Server as ts framing = ( FramingEncode framing as , MimeTypes ts (MimeEncodable (FramingYield as)) ) type ResponseStreamArgs Server as ts framing = ServerResponseStream framing ts IO as type ResponseStream Server = Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived responseStream :: forall as ts framing repr. ResponseStreamConstraint repr as ts framing => repr ~ Server => HTTP.Method -> repr (ResponseStreamArgs repr as ts framing) (ResponseStream repr) responseStream expMethod = Server $ do st@ServerState { serverState_request = req } <- S.get -- Check the path has been fully consumed unless (List.null $ Wai.pathInfo req) $ MC.throw $ Fail st [ServerErrorPath "path is longer"] -- Check the method let reqMethod = Wai.requestMethod $ serverState_request st unless (reqMethod == expMethod || reqMethod == HTTP.methodHead && expMethod == HTTP.methodGet) $ MC.throw $ Fail st [ServerErrorMethod] -- Check the Accept header let reqHeaders = Wai.requestHeaders $ serverState_request st MimeType reqAccept <- do case List.lookup HTTP.hAccept reqHeaders of Nothing -> return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as)) Just h -> case matchAccept @ts @(MimeEncodable (FramingYield as)) h of Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))] Just mt -> return mt return $ \(ServerResponseStream k) rq re -> re =<< do C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) -> return{-IO-} $ Wai.responseStream sta ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept) : hs ) $ \write flush -> if reqMethod == HTTP.methodHead then flush else let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in let go curr = case curr of Left _end -> flush Right (bsl, next) -> do unless (BSL.null bsl) $ do write (BSB.lazyByteString bsl) flush enc next >>= go in enc as >>= go -- | Return worse 'HTTP.Status'. instance Semigroup HTTP.Status where x <> y = if rank (HTTP.statusCode x) < rank (HTTP.statusCode y) then x else y where rank :: Int -> Int rank 404 = 0 -- Not Found rank 405 = 1 -- Method Not Allowed rank 401 = 2 -- Unauthorized rank 415 = 3 -- Unsupported Media Type rank 406 = 4 -- Not Acceptable rank 400 = 5 -- Bad Request rank _ = 6 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'. instance Monoid HTTP.Status where mempty = HTTP.status200 mappend = (<>) -- * Type 'Router' -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'. data Router repr a b where -- | Lift any @(repr)@ into 'Router', those not useful to segregate -- wrt. the 'Trans'formation performed, aka. 'noTrans'. Router_Any :: repr a b -> Router repr a b -- | Represent 'segment'. Router_Seg :: PathSegment -> Router repr k k -- | Represent ('<.>'). Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c -- | Represent 'routing'. Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k Router_Map2 :: Map.Map PathSegment (Segments (Router repr) ms k) -> Router repr (Caps2Alts ms) k -- | Represent (''). Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k -- | Used to transform 'Router_Alt' into 'Router_Map', -- while following the way ('') combinators are associated in the API. -- Use 'router_AltL' to insert it correctly. Router_AltL :: Router repr a k -> Router repr (a:!:b) k -- | Used to transform 'Router_Alt' into 'Router_Map' -- while following the way ('') combinators are associated in the API. -- Use 'router_AltR' to insert it correctly. Router_AltR :: Router repr b k -> Router repr (a:!:b) k -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k Router_Cap :: PathConstraint Server a => Name -> Router repr (a->k) k Router_Caps :: Captures xs -> Router repr (Caps2Alts xs) (Caps2AltsCoDomain xs) -- ** Type 'Tree' -- | Use @DataKinds@ to define a 'Tree' of 'Type's. -- Useful for factorizing 'capture's of different 'Type's. data Tree a = Tree0 a | Tree2 (Tree a) (Tree a) -- ** Type 'Segments' data Segments repr (cs::Tree Type) k where Segments0 :: repr a k -> Segments repr ('Tree0 a) k SegmentsL :: Segments repr a k -> Segments repr ('Tree2 a b) k SegmentsR :: Segments repr b k -> Segments repr ('Tree2 a b) k SegmentsB :: repr (a:!:b) k -> Segments repr ('Tree2 (Tree0 a) (Tree0 b)) k Segments2 :: Segments repr x k -> Segments repr y k -> Segments repr ('Tree2 x y) k SegmentsLL :: Segments (Router repr) ('Tree2 a1 b) k -> Segments (Router repr) ('Tree2 ('Tree2 a1 b1) b) k -- ** Type 'Segs' data Segs repr (cs::Type) k where Segs0 :: repr a k -> Segs repr (a) k SegsL :: Segs repr a k -> Segs repr (a:!:b) k SegsR :: Segs repr b k -> Segs repr (a:!:b) k SegsB :: repr (a:!:b) k -> Segs repr (a:!:b) k Segs2 :: Segs repr x k -> Segs repr y k -> Segs repr (x:!:y) k {- mergeSegs :: Segs (Router repr) a k -> Segs (Router repr) b k -> Segs (Router repr) (a:!:b) k mergeSegs (Segs0 x) (Segs0 y) = Segs0 (x`router_Alt`y) -- mergeSegs (SegsL x) y = _e $ mergeSegs x y -- mergeSegs (SegsL x) y = SegsLL $ mergeSegs x y -} -- ** Type 'Captures' data Captures (cs::Tree Type) where Captures0 :: PathConstraint Server a => Proxy (a->k) -> Name -> -- repr x k -> Captures ('Tree0 (a->k)) Captures2 :: Captures x -> Captures y -> Captures ('Tree2 x y) -- ** Type 'Captured' data Captured (cs::Tree Type) where Captured0 :: a -> Captured ('Tree0 a) Captured2 :: Captured x -> Captured y -> Captured ('Tree2 x y) -- ** Type family 'Caps2Alts' type family Caps2Alts (cs::Tree Type) :: Type where Caps2Alts ('Tree0 x) = x Caps2Alts ('Tree2 x y) = Caps2Alts x :!: Caps2Alts y -- ** Type family 'Caps2AltsCoDomain' type family Caps2AltsCoDomain (cs::Tree Type) :: Type where Caps2AltsCoDomain ('Tree0 a2k) = CoDomain a2k Caps2AltsCoDomain ('Tree2 x y) = Caps2AltsCoDomain x :!: Caps2AltsCoDomain y -- ** Type family 'Domain' type family Domain x :: * where Domain (a->b) = a -- ** Type family 'CoDomain' type family CoDomain x :: * where CoDomain (a->b) = b -- ** Class 'Alts2Caps' class Alts2Caps cs where alts2caps :: Caps2Alts cs -> Captured cs instance Alts2Caps ('Tree0 a) where alts2caps a = Captured0 a instance (Alts2Caps x, Alts2Caps y) => Alts2Caps ('Tree2 x y) where alts2caps (a:!:b) = Captured2 (alts2caps a) (alts2caps b) instance Trans (Router Server) where type UnTrans (Router Server) = Server noTrans = Router_Any unTrans (Router_Any x) = x unTrans (Router_Seg s) = segment s unTrans (Router_Cat x y) = unTrans x <.> unTrans y unTrans (Router_Alt x y) = unTrans x unTrans y unTrans (Router_AltL x) = Server $ (\a2k (a:!:_b) -> a2k a) <$> unServer (unTrans x) unTrans (Router_AltR x) = Server $ (\b2k (_a:!:b) -> b2k b) <$> unServer (unTrans x) unTrans (Router_Map ms) = routing (unTrans <$> ms) unTrans (Router_Cap n) = capture' n unTrans (Router_Caps xs) = captures xs -- Server $ _e <$> unServer (captures xs) {- unTrans (Router_Caps xs) = Server $ (\c2k -> c2k . alts2caps) <$> unServer (captures (unTransCaptures xs)) where unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r) unTransCaptures (Captures2 x y) = unTransCaptures x `Captures2` unTransCaptures y -} instance Cat (Router Server) where (<.>) = Router_Cat instance Alt (Router Server) where () = Router_Alt instance repr ~ Server => HTTP_Path (Router repr) where type PathConstraint (Router repr) a = PathConstraint repr a segment = Router_Seg capture' = Router_Cap instance HTTP_Routing (Router Server) where routing = Router_Map captures = Router_Caps -- . unTransCaptures {- where unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r) unTransCaptures (Captures2 x y) = unTransCaptures x `Captures2` unTransCaptures y -} instance Pro (Router Server) instance HTTP_Query (Router Server) instance HTTP_Header (Router Server) instance HTTP_Body (Router Server) instance HTTP_BodyStream (Router Server) instance HTTP_BasicAuth (Router Server) instance HTTP_Response (Router Server) instance HTTP_ResponseStream (Router Server) -- ** Class 'HTTP_Routing' class HTTP_Routing repr where routing :: Map.Map PathSegment (repr a k) -> repr a k captures :: Captures cs -> repr (Caps2Alts cs) (Caps2AltsCoDomain cs) -- Trans defaults default routing :: Trans repr => HTTP_Routing (UnTrans repr) => Map.Map PathSegment (repr a k) -> repr a k routing = noTrans . routing . (unTrans <$>) {- NOTE: cannot define this default simply, - due to the need for: forall a. PathConstraint (Router repr) a ~ PathConstraint repr a - so let's just define it in (HTTP_Routing (Router Server)) default captures :: Trans repr => HTTP_Routing (UnTrans repr) => Captures cs -> repr (Captured cs) k captures = noTrans . captures . unTransCaptures where unTransCaptures :: Captures cs -> Captures cs unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r) unTransCaptures (Captures2 x y) = Captures2 (unTransCaptures x) (unTransCaptures y) -} instance HTTP_Routing Server where routing ms = Server $ do st@ServerState { serverState_request = req } <- S.get case Wai.pathInfo req of [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"] [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"] curr:next -> case Map.lookup curr ms of Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr] Just x -> do S.put st { serverState_request = req{ Wai.pathInfo = next } } unServer x captures :: Captures cs -> Server (Caps2Alts cs) (Caps2AltsCoDomain cs) captures cs = Server $ do st@ServerState { serverState_request = req } <- S.get case Wai.pathInfo req of [] -> MC.throw $ Fail st [ServerErrorPath "empty"] [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"] currSeg:nextSeg -> case go cs of Left errs -> MC.throw $ Fail st [ServerErrorPath $ "captures: "<>fromString (List.intercalate "|" ((\(name,err) -> name) <$> errs))] Right a -> unServer a where go :: forall cs. Captures cs -> Either [(Name,Text)] (Server (Caps2Alts cs) (Caps2AltsCoDomain cs)) go (Captures0 (Proxy::Proxy (a->x)) name) = case Web.parseUrlPiece currSeg of Left err -> Left [(name,err)] Right (a::a) -> Right $ Server $ do S.put st { serverState_request = req{ Wai.pathInfo = nextSeg } } return ($ a) go (Captures2 x y) = case go x of Left xe -> case go y of Left ye -> Left (xe<>ye) Right a -> Right $ Server $ (\y2ky (_x:!:y') -> undefined:!:y2ky y') <$> unServer a Right a -> Right $ Server $ (\x2kx (x':!:_y) -> x2kx x':!:undefined) <$> unServer a -- | Traverse a 'Router' to transform 'Router_Alt' -- into 'Router_Map' when possible. -- Used in 'server' on the 'Router' inferred from the given API. -- router :: Router repr a b -> Router repr a b router :: repr ~ Server => Router repr a b -> Router repr a b router i = case {-Dbg.trace ("router: " <> show i)-} i of x@Router_Any{} -> x x@Router_Seg{} -> x {- Router_Cat (Router_Seg s) (l`Router_Alt`r) -> (Router_Cat (Router_Seg s) l) `Router_Alt` (Router_Cat (Router_Seg s) r) -} Router_Cat x y -> router x `Router_Cat` router y Router_Alt x y -> router_Alt x y Router_AltL x -> Router_AltL (router x) Router_AltR x -> Router_AltR (router x) Router_Map xs -> Router_Map (router <$> xs) Router_Cap n -> Router_Cap n Router_Caps cs -> Router_Caps ({-go-} cs) {- where go :: Captures (Router repr) cs k -> Captures (Router repr) cs k go (Captures0 a n r) = Captures0 a n (router r) go (Captures2 x y) = Captures2 (go x) (go y) -} router_Cat :: repr ~ Server => Router repr a b -> Router repr b c -> Router repr a c router_Cat x0 y0 = let r = go ({-Dbg.trace ("cat: x: " <> show x0)-} x0) ({-Dbg.trace ("cat: y: " <> show y0)-} y0) in {-Dbg.trace ("cat: r: " <> show r)-} r where go x y = Router_Cat x y {- go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) = -} -- | Insert a 'Router_Alt' or a 'Router_Map' if possible. router_Alt :: {- PathConstraint (Router repr) a ~ PathConstraint repr a => PathConstraint (Router repr) b ~ PathConstraint repr b => -} repr ~ Server => Router repr a k -> Router repr b k -> Router repr (a:!:b) k router_Alt x0 y0 = let r = go ({-Dbg.trace ("alt: x: " <> show x0)-} x0) ({-Dbg.trace ("alt: y: " <> show y0)-} y0) in {-Dbg.trace ("alt: r: " <> show r)-} r where go :: forall a b k repr. repr ~ Server => Router repr a k -> Router repr b k -> Router repr (a:!:b) k {- go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) | x == y = Router_Seg y `Router_Cat` (xt `router_Alt` yt) | otherwise = Router_Map2 $ Map.fromListWith (\_xt _yt -> SegmentsB $ xt `router_Alt` yt) [ (x, SegmentsL (Segments0 xt)) , (y, SegmentsR (Segments0 yt)) ] go (Router_Seg x `Router_Cat` xt) (Router_Map2 ys) = {- let l = Map.singleton x (SegmentsL (Segments0 xt)) in let r = SegmentsR <$> ys in Router_Map2 $ l <> r -} Router_Map2 $ Map.merge (Map.traverseMissing $ const $ return . SegmentsL . Segments0) (Map.traverseMissing $ const $ return . SegmentsR) (Map.zipWithAMatched $ const $ \a b -> return $ Segments2 (Segments0 a) b) (Map.singleton x xt) ys -} {- go (Router_Map2 xs) (Router_Seg y `Router_Cat` yt) = Router_Map2 $ Map.merge (Map.traverseMissing $ const $ return . SegmentsL) (Map.traverseMissing $ const $ return . SegmentsR) (Map.zipWithAMatched $ const $ \a b -> return $ SegmentsB $ a`router_Alt`b) xs (Map.singleton y yt) go (Router_Map2 xs) (Router_Map2 ys) = Router_Map2 $ Map.merge (Map.traverseMissing $ const $ return . SegmentsL) (Map.traverseMissing $ const $ return . SegmentsR) (Map.zipWithAMatched $ const $ \a b -> return $ SegmentsB $ a`router_Alt`b) xs ys -} go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) | x == y = Router_Seg y `Router_Cat` (xt `router_Alt` yt) | otherwise = Router_Map $ Map.fromListWith (\_xt _yt -> xt `router_Alt` yt) [ (x, router_AltL xt) , (y, router_AltR yt) ] go (Router_Seg x `Router_Cat` xt) (Router_Map ys) = Router_Map $ Map.merge (Map.traverseMissing $ const $ return . router_AltL . router) (Map.traverseMissing $ const $ return . router_AltR . router) (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b) (Map.singleton x xt) ys go (Router_Map xs) (Router_Seg y `Router_Cat` yt) = Router_Map $ Map.merge (Map.traverseMissing $ const $ return . router_AltL . router) (Map.traverseMissing $ const $ return . router_AltR . router) (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b) xs (Map.singleton y yt) go (Router_Map xs) (Router_Map ys) = Router_Map $ Map.merge (Map.traverseMissing $ const $ return . router_AltL . router) (Map.traverseMissing $ const $ return . router_AltR . router) (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b) xs ys go (Router_Cat (Router_Cat x y) z) w = router_Alt (Router_Cat x (Router_Cat y z)) w go w (Router_Cat (Router_Cat x y) z) = router_Alt w (Router_Cat x (Router_Cat y z)) go (Router_Cap xn `Router_Cat` x) (Router_Cap yn `Router_Cat` y) = Router_Caps (Captures0 Proxy xn `Captures2` Captures0 Proxy yn) `Router_Cat` (x`router_Alt`y) go (Router_Caps xs `Router_Cat` x) (Router_Caps ys `Router_Cat` y) = Router_Caps (xs`Captures2`ys) `Router_Cat` router_Alt x y go (Router_Cap xn `Router_Cat` x) (Router_Caps ys `Router_Cat` y) = Router_Caps (Captures0 Proxy xn `Captures2` ys) `Router_Cat` router_Alt x y go (Router_Caps xs `Router_Cat` x) (Router_Cap yn `Router_Cat` y) = Router_Caps (xs `Captures2` Captures0 Proxy yn) `Router_Cat` router_Alt x y {- go x (Router_AltL y) = case router_Alt x y of Router_Alt x' y' -> Router_Alt x' (router_AltL y') _ -> Router_Alt x (Router_AltL y) go x (Router_AltR y) = case router_Alt x y of Router_Alt x' y' -> Router_Alt x' (router_AltR y') _ -> Router_Alt x (Router_AltR y) go (Router_AltL x) y = case router_Alt x y of Router_Alt x' y' -> Router_Alt (router_AltL x') y' _ -> Router_Alt (Router_AltL x) y go (Router_AltR x) y = case router_Alt x y of Router_Alt x' y' -> Router_Alt (router_AltR x') y' _ -> Router_Alt (Router_AltR x) y -} go x (Router_Alt y z) = case router_Alt y z of yz@Router_Alt{} -> Router_Alt x yz yz -> router_Alt x yz go (Router_Alt x y) z = case router_Alt x y of xy@Router_Alt{} -> Router_Alt xy z xy -> router_Alt xy z go x y = Router_Alt (router x) (router y) -- | Insert a 'Router_AltL' as deep as possible -- in order to not prevent the transformation -- of 'Router_Alt' into 'Router_Map' in 'router_Alt'. router_AltL :: repr ~ Server => Router repr a k -> Router repr (a:!:b) k router_AltL = \case Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltL y) Router_Cat x y -> Router_Cat (router_AltL x) y Router_Map xs -> Router_Map (router_AltL <$> xs) -- Router_Alt x y -> Router_Alt x y {- Router_Caps (Captures0 a n r) -> let () = Router_Caps (Captures0 a n (router_AltL r)) in _e Router_Caps xs -> Router_Caps (mapCaptures xs) where -- mapCaptures :: Captures (Router repr) a k -> Captures (Router repr) (a:!:b) k mapCaptures (Captures0 a n r) = Captures0 a n (router_AltL r) -- mapCaptures (Captures2 x y) = Captures2 (mapCaptures x) (mapCaptures y) -} d -> Router_AltL d -- Router_Any x -> Router_Any $ Server $ (\a2k (a:!:_b) -> a2k a) <$> unServer x -- | Like 'router_AltL' but for 'Router_AltR'. router_AltR :: repr ~ Server => Router repr b k -> Router repr (a:!:b) k router_AltR = \case Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltR y) Router_Cat x y -> Router_Cat (router_AltR x) y -- Router_Alt x y -> router_AltR (Router_Alt x y) Router_Map xs -> Router_Map (router_AltR <$> xs) d -> Router_AltR d