diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,13 +2,24 @@ ## Unreleased changes -## [0.1.0] - 2020-08-16 +## [0.2.0] - 2020-09-11 ### Added +- Support GHC 8.10 and 8.6 (#10) +- Added more traits and middlewares (#7) +- Performance benchmarks (#6) +- Set up a website (#13) +### Changed +- A lot of refactorings (#20, #21, #22, #23) + +## [0.1.0] - 2020-08-16 + +### Added - Support basic traits and middlewares - Automated tests - Documentation -[0.1.0]: https://github.com/rkaippully/webgear/compare/0.0.0...0.1.0 -[Unreleased]: https://github.com/rkaippully/webgear/compare/0.1.0...HEAD +[Unreleased]: https://github.com/rkaippully/webgear/compare/v0.2.0...HEAD +[0.2.0]: https://github.com/rkaippully/webgear/compare/v0.1.0...v0.2.0 +[0.1.0]: https://github.com/rkaippully/webgear/releases/tag/v0.1.0 diff --git a/src/WebGear.hs b/src/WebGear.hs --- a/src/WebGear.hs +++ b/src/WebGear.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_HADDOCK ignore-exports #-} -- | -- Copyright : (c) Raghu Kaippully, 2020 -- License : MPL-2.0 @@ -28,21 +29,34 @@ -- * Running the Server -- $running + + -- * Servers with other monads + -- $otherMonads + + module Control.Applicative + , module Control.Arrow + , module Data.ByteString.Lazy + , module Data.ByteString.Conversion.To + , module Data.Proxy + , module Data.Text + , module Web.HttpApiData + , module WebGear.Middlewares + , module WebGear.Trait + , module WebGear.Types ) where -import Control.Applicative (Alternative (..)) +import Control.Applicative (Alternative ((<|>))) import Control.Arrow (Kleisli (..)) -import Web.HttpApiData (FromHttpApiData) +import Data.ByteString.Conversion.To +import Data.ByteString.Lazy (ByteString) +import Data.Proxy (Proxy (..)) +import Data.Text +import Web.HttpApiData (FromHttpApiData (..)) import qualified Network.Wai as Wai import WebGear.Middlewares -import WebGear.Route import WebGear.Trait -import WebGear.Trait.Body -import WebGear.Trait.Header -import WebGear.Trait.Method -import WebGear.Trait.Path import WebGear.Types @@ -53,10 +67,14 @@ -- takes a request as input and produces a response as output in a -- monadic context. -- --- @ --- handler :: Monad m => 'Request' -> m 'Response' --- @ +-- > handler :: Monad m => Request -> m Response -- +-- For reasons that will be explained later, WebGear uses the 'Router' +-- monad for running handlers. Thus the above type signature changes +-- to: +-- +-- > handler :: Request -> Router Response +-- -- Most APIs will require extracting some information from the -- request, processing it and then producing a response. For example, -- the server might require access to some HTTP header values, query @@ -67,33 +85,37 @@ -- $traits -- -- A trait is an attribute associated with a value. For example, a --- @Request@ might have a header that we are interested in; the --- 'Header' trait represents that. All traits have instances of --- 'Trait' typeclass. This typeclass helps to 'check' the presence of --- the trait. It also has two associated types - 'Val' and 'Fail' - to --- represent the result of 'check'ing the presence of a trait. +-- @Request@ might have a header that we are interested in, which is +-- represented by the 'Header' trait. All traits have instances of the +-- 'Trait' typeclass. The 'toAttribute' function helps to check +-- presence of the trait. It also has two associated types - +-- 'Attribute' and 'Absence' - to represent the result of the +-- extraction. -- -- For example, the 'Header' trait has an instance of the 'Trait' --- typeclass. The 'check' function evaluates to a 'CheckSuccess' value --- if the header exists and can be converted to an attribute via the --- 'FromHttpApiData' typeclass. Otherwise, it evaluates to a --- 'CheckFail' value. +-- typeclass. The 'toAttribute' function evaluates to a 'Found' or +-- 'NotFound' value depending on whether we can successfully retrieve +-- the header value. -- --- WebGear provides type-safety by linking traits to the request or --- response at type level. The 'Linked' data type associates a --- 'Request' or 'Response' with a list of traits. This linking --- guarantees that the Request or Response has the specified trait. +-- WebGear provides type-safety by linking traits to the request at +-- type level. The 'Linked' data type associates a 'Request' with a +-- list of traits. This linking guarantees that the Request has the +-- specified trait. -- -- These functions work with traits and linked values: -- --- * 'linkzero': Establish a link between a value and an empty list --- of traits. This always succeeds. --- * 'linkplus': Attempts to establish a link between a linked value --- with an additional trait. --- * 'linkminus': Removes a trait from the list of linked traits. +-- * 'link': Establish a link between a value and an empty list of +-- traits. This always succeeds. +-- -- * 'unlink': Convert a linked value to a regular value without any -- type-level traits. --- * 'traitValue': Extract a 'Val' associated with a trait from a +-- +-- * 'probe': Attempts to establish a link between a linked value +-- with an additional trait using 'toAttribute'. +-- +-- * 'remove': Removes a trait from the list of linked traits. +-- +-- * 'get': Extract an 'Attribute' associated with a trait from a -- linked value. -- -- For example, we make use of the @'Method' \@GET@ trait to ensure @@ -101,21 +123,19 @@ -- request value with this trait using: -- -- @ --- linkedRequest :: Monad m => 'Request' -> m (Either 'MethodMismatch' ('Linked' '['Method' GET] 'Request')) --- linkedRequest = 'linkplus' @('Method' GET) . 'linkzero' +-- linkedRequest :: Monad m => 'Request' -> 'Router' (Either 'MethodMismatch' ('Linked' '['Method' GET] 'Request')) +-- linkedRequest = 'probe' @('Method' GET) . 'link' -- @ -- -- Let us modify the type signature of our handler to use linked -- values instead of regular values: -- --- > handler :: Monad m => Linked req Request -> m (Linked res Response) +-- > handler :: Linked req Request -> Router Response -- -- Here, @req@ is a type-level list of traits associated with the --- @Request@ that this handler requires and @res@ is a type-level list --- of traits associated with the @Response@ that this handler will --- produce. This implies that this handler can be called only with a --- request possessing certain traits and it is guaranteed to produce a --- response having certain traits. +-- @Request@ that this handler requires. This ensures that this +-- handler can only be called with a request possessing certain +-- traits thus providing type-safety to our handlers. -- -- -- $handlers @@ -124,7 +144,9 @@ -- above. -- -- @ --- type 'Handler' m req res a = 'Kleisli' m ('Linked' req 'Request') ('Linked' res ('Response' a)) +-- type 'Handler'' m req a = 'Kleisli' m ('Linked' req 'Request') ('Response' a) +-- +-- type 'Handler' req a = 'Handler'' 'Router' req a -- @ -- -- It is a 'Kleisli' arrow as described in the above section with @@ -132,36 +154,37 @@ -- the type variable @a@, which represents the type of the response -- body. -- +-- 'Handler'' can work with any monad while 'Handler' works with +-- 'Router'. +-- -- A handler can extract some trait attribute of a request with the --- 'traitValue' function. It can also use 'linkplus' function to prove --- the presence of traits in the response before returning it. +-- 'get' function. -- -- -- $middlewares -- -- A middleware is a higher-order function that takes a handler as --- input and produces another handler with potentially different lists --- of request and response traits. Thus middlewares can augment the +-- input and produces another handler with potentially different +-- request and response types. Thus middlewares can augment the -- functionality of another handler. -- -- For example, here is the definition of the 'method' middleware: -- -- @ --- method :: ('IsStdMethod' t, 'MonadRouter' m) => 'Handler' m ('Method' t:req) res a -> 'Handler' m req res a --- method handler = 'Kleisli' $ 'linkplus' \@('Method' t) >=> 'either' ('const' 'rejectRoute') ('runKleisli' handler) +-- method :: ('IsStdMethod' t, 'MonadRouter' m) => 'Handler'' m ('Method' t:req) a -> 'Handler'' m req a +-- method handler = 'Kleisli' $ 'probe' \@('Method' t) >=> 'either' ('const' 'rejectRoute') ('runKleisli' handler) -- @ -- --- The @linkplus \@(Method t)@ function is used to prove the presence --- of the method @t@ in the request and the @handler@ is invoked only --- if the method matches. In case of a mismatch, this route is --- rejected by calling 'rejectRoute'. +-- The @probe \@(Method t)@ function is used to ensure that the +-- request has method @t@ before invoking the @handler@. In case of a +-- mismatch, this route is rejected by calling 'rejectRoute'. -- -- Many middlewares can be composed to form complex request handling --- logic. +-- logic. For example: -- -- @ -- putUser = 'method' \@PUT --- $ 'requestContentType' \@"application/json" +-- $ 'requestContentTypeHeader' \@"application/json" -- $ 'jsonRequestBody' \@User -- $ 'jsonResponseBody' \@User -- $ putUserHandler @@ -181,14 +204,15 @@ -- @ -- class (Alternative m, MonadPlus m) => 'MonadRouter' m where -- 'rejectRoute' :: m a --- 'failHandler' :: 'Response' ByteString -> m a +-- 'errorResponse' :: 'Response' 'ByteString' -> m a +-- 'catchErrorResponse' :: m a -> ('Response' 'ByteString' -> m a) -> m a -- @ -- --- The 'failHandler' can be used in cases where we find a matching +-- The 'errorResponse' can be used in cases where we find a matching -- route but the request handling is aborted for some reason. For -- example, if a route requires the request Content-type header to -- have a particular value but the actual request had a different --- Content-type, 'failHandler' can be used to abort and return an +-- Content-type, 'errorResponse' can be used to abort and return an -- error response. -- -- Second, we need a mechanism to try an alternate route when one @@ -199,45 +223,68 @@ -- example: -- -- @ --- allRoutes :: 'MonadRouter' m => 'Handler' m '[] '[] ByteString --- allRoutes = ['match'| v1\/users\/userId:Int |] -- non-TH version: 'path' \@"v1/users" . 'pathVar' \@"userId" \@Int +-- allRoutes :: 'Handler' '[] 'ByteString' +-- allRoutes = ['match'| /v1\/users\/userId:Int |] -- non-TH version: 'path' \@"/v1/users" . 'pathVar' \@"userId" \@Int -- $ getUser \<|\> putUser \<|\> deleteUser -- -- type IntUserId = 'PathVar' "userId" Int -- --- getUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString +-- getUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' -- getUser = 'method' \@GET getUserHandler -- --- putUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString +-- putUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' -- putUser = 'method' \@PUT --- $ 'requestContentType' \@"application/json" +-- $ 'requestContentTypeHeader' \@"application/json" -- $ 'jsonRequestBody' \@User -- $ putUserHandler -- --- deleteUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString +-- deleteUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' -- deleteUser = 'method' \@DELETE deleteUserHandler -- @ -- -- -- $running -- --- Routable handlers can be converted to a regular function using --- 'runRoute': +-- Routable handlers can be converted to a Wai 'Wai.Application' using +-- 'toApplication': -- -- @ --- runRoute :: Monad m => 'Handler' (RouterT m) '[] res ByteString -> ('Wai.Request' -> m 'Wai.Response') +-- toApplication :: 'ToByteString' a => 'Handler' '[] a -> 'Wai.Application' -- @ -- --- This function converts a WebGear handler to a function from --- 'Wai.Request' to 'Wai.Response' in a monadic context @m@. Then it --- is trivial to convert that to a WAI 'Wai.Application' and run it as a --- warp server: +-- This Wai application can then be run as a Warp web server. -- -- @ --- application :: 'Wai.Application' --- application req respond = 'runRoute' allRoutes req >>= respond --- -- main :: IO () --- main = Warp.run 3000 application +-- main = Warp.run 3000 $ 'toApplication' allRoutes -- @ +-- +-- +-- $otherMonads +-- +-- It may not be practical to use 'Router' monad for your handlers. In +-- most cases, you would need your own monad transformer stack or +-- algebraic effect runners. WebGear supports that easily. +-- +-- Let us say, the @putUserHandler@ from the above example runs on +-- some monad other than 'Router'. You can still use it as a handler thus: +-- +-- @ +-- putUser = 'method' \@PUT +-- $ 'requestContentTypeHeader' \@"application/json" +-- $ 'jsonRequestBody' \@User +-- $ 'jsonResponseBody' \@User +-- $ 'transform' customMonadToRouter putUserHandler +-- +-- putUserHandler :: 'Handler'' MyCustomMonad req User +-- putUserHandler = .... +-- +-- customMonadToRouter :: MyCustomMonad a -> Router a +-- customMonadToRouter = ... +-- @ +-- +-- As long as you have a way of transforming values in your custom +-- monad to a 'Router' monadic value, you can use 'transform' to +-- convert the handlers in that custom monad to handlers running in +-- 'Router' monad. -- diff --git a/src/WebGear/Middlewares.hs b/src/WebGear/Middlewares.hs --- a/src/WebGear/Middlewares.hs +++ b/src/WebGear/Middlewares.hs @@ -6,41 +6,17 @@ -- Middlewares provided by WebGear. -- module WebGear.Middlewares - ( ok - , noContent - , badRequest - , notFound - - , module WebGear.Middlewares.Method + ( module WebGear.Middlewares.Method , module WebGear.Middlewares.Path , module WebGear.Middlewares.Header , module WebGear.Middlewares.Body + , module WebGear.Middlewares.Params + , module WebGear.Middlewares.Auth.Basic ) where -import Data.String (IsString) - +import WebGear.Middlewares.Auth.Basic import WebGear.Middlewares.Body import WebGear.Middlewares.Header import WebGear.Middlewares.Method +import WebGear.Middlewares.Params import WebGear.Middlewares.Path -import WebGear.Trait (Linked, linkzero) -import WebGear.Types (Response (..)) - -import qualified Network.HTTP.Types as HTTP - - --- | Respond with a 200 OK -ok :: Monad m => a -> m (Linked '[] (Response a)) -ok = pure . linkzero . Response HTTP.ok200 mempty . Just - --- | Respond with a 400 Bad Request -badRequest :: Monad m => m (Linked '[] (Response a)) -badRequest = pure $ linkzero $ Response HTTP.badRequest400 mempty Nothing - --- | Respond with a 404 NotFound -notFound :: Monad m => m (Linked '[] (Response a)) -notFound = pure $ linkzero $ Response HTTP.notFound404 mempty Nothing - --- | Respond with a 204 NoContent -noContent :: (Monad m, IsString s) => m (Linked '[] (Response s)) -noContent = pure $ linkzero $ Response HTTP.noContent204 mempty $ Just "" diff --git a/src/WebGear/Middlewares/Auth/Basic.hs b/src/WebGear/Middlewares/Auth/Basic.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Middlewares/Auth/Basic.hs @@ -0,0 +1,120 @@ +-- | +-- Copyright : (c) Raghu Kaippully, 2020 +-- License : MPL-2.0 +-- Maintainer : rkaippully@gmail.com +-- +-- Basic authentication support. +-- +module WebGear.Middlewares.Auth.Basic + ( BasicAuth + , Realm (..) + , Username (..) + , Password (..) + , Credentials (..) + , BasicAuthError (..) + , basicAuth + ) where + +import Control.Arrow (Kleisli (..)) +import Control.Monad (when, (>=>)) +import Control.Monad.Except (throwError) +import Data.ByteString (ByteString, intercalate) +import Data.ByteString.Base64 (decodeLenient) +import Data.ByteString.Char8 (split) +import Data.CaseInsensitive (CI, mk) +import Data.Proxy (Proxy (..)) +import Data.String (IsString) + +import WebGear.Trait (Has (..), Linked, Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), forbidden403, + requestHeader, setResponseHeader, unauthorized401) +import WebGear.Util (maybeToRight) + + +-- | Trait for HTTP basic authentication: https://tools.ietf.org/html/rfc7617 +data BasicAuth + +-- | The protection space for basic authentication +newtype Realm = Realm ByteString + deriving newtype (Eq, Ord, Show, Read, IsString) + +-- | Username for basic authentication. Valid usernames cannot contain +-- \':\' characters. +newtype Username = Username ByteString + deriving newtype (Eq, Ord, Show, Read, IsString) + +-- | Password for basic authentication. +newtype Password = Password ByteString + deriving newtype (Eq, Ord, Show, Read, IsString) + +-- | Basic authentication credentials retrieved from an HTTP request +data Credentials = Credentials + { credentialsUsername :: !Username + , credentialsPassword :: !Password + } + deriving (Eq, Ord, Show, Read) + +-- | Error extracting credentials from an HTTP request +data BasicAuthError = AuthHeaderError -- ^ Authorization header is missing or badly formatted + | AuthSchemeMismatch -- ^ Authorization scheme is not "Basic" + deriving (Eq, Ord, Show, Read) + +instance Monad m => Trait BasicAuth Request m where + type Attribute BasicAuth Request = Credentials + type Absence BasicAuth Request = BasicAuthError + + toAttribute :: Request -> m (Result BasicAuth Request) + toAttribute r = pure $ either NotFound Found $ do + h <- getAuthHeader r + (scheme, creds) <- parseAuthHeader h + when (scheme /= "Basic") $ + throwError AuthSchemeMismatch + parseCreds creds + +type Scheme = CI ByteString +type EncodedPassword = ByteString + +getAuthHeader :: Request -> Either BasicAuthError ByteString +getAuthHeader r = maybeToRight AuthHeaderError $ requestHeader "Authorization" r + +parseAuthHeader :: ByteString -> Either BasicAuthError (Scheme, EncodedPassword) +parseAuthHeader s = + case split ' ' s of + [x, y] -> pure (mk x, y) + _ -> throwError AuthHeaderError + +parseCreds :: EncodedPassword -> Either BasicAuthError Credentials +parseCreds enc = + case split ':' (decodeLenient enc) of + [] -> throwError AuthHeaderError + u:ps -> pure $ Credentials (Username u) (Password $ intercalate ":" ps) + +-- | Middleware to add basic authentication protection for a handler. +-- +-- Example usage: +-- +-- > basicAuth "realm" isValidCredentials handler +-- +-- This middleware returns a 401 response if no credentials are found +-- in the request. It returns a 403 response if credentials are +-- present but isValidCredentials returns False. +-- +basicAuth :: forall m req a. MonadRouter m + => Realm + -> (Credentials -> m Bool) + -> RequestMiddleware' m req (BasicAuth : req) a +basicAuth (Realm realm) credCheck handler = Kleisli $ + probe @BasicAuth >=> either unauthorized (validateCredentials >=> runKleisli handler) + where + unauthorized :: BasicAuthError -> m (Response a) + unauthorized = const $ errorResponse + $ setResponseHeader "WWW-Authenticate" ("Basic realm=\"" <> realm <> "\"") + $ unauthorized401 "Unauthorized" + + validateCredentials :: Linked (BasicAuth : req) Request + -> m (Linked (BasicAuth : req) Request) + validateCredentials req = do + valid <- credCheck $ get (Proxy @BasicAuth) req + if valid + then pure req + else errorResponse $ forbidden403 "Forbidden" diff --git a/src/WebGear/Middlewares/Body.hs b/src/WebGear/Middlewares/Body.hs --- a/src/WebGear/Middlewares/Body.hs +++ b/src/WebGear/Middlewares/Body.hs @@ -5,26 +5,40 @@ -- -- Middlewares related to HTTP body. module WebGear.Middlewares.Body - ( jsonRequestBody + ( JSONRequestBody + , jsonRequestBody , jsonResponseBody ) where import Control.Arrow (Kleisli (..)) import Control.Monad ((>=>)) -import Control.Monad.IO.Class (MonadIO) -import Data.Aeson (FromJSON, ToJSON, encode) -import Data.ByteString.Lazy (ByteString, fromStrict) -import Data.HashMap.Strict (fromList, insert) -import Data.Text (Text) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON, eitherDecode', encode) +import Data.ByteString.Lazy (ByteString, fromChunks, fromStrict) +import Data.Kind (Type) +import Data.Text (Text, pack) import Data.Text.Encoding (encodeUtf8) -import Network.HTTP.Types (badRequest400, hContentType) +import Network.HTTP.Types (hContentType) -import WebGear.Route (MonadRouter (..)) -import WebGear.Trait (linkplus, linkzero, unlink) -import WebGear.Trait.Body (JSONRequestBody) -import WebGear.Types (Middleware, RequestMiddleware, Response (..)) +import WebGear.Trait (Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), + ResponseMiddleware', badRequest400, getRequestBodyChunk, setResponseHeader) +import WebGear.Util (takeWhileM) +-- | A 'Trait' for converting a JSON request body into a value. +data JSONRequestBody (t :: Type) +instance (FromJSON t, MonadIO m) => Trait (JSONRequestBody t) Request m where + type Attribute (JSONRequestBody t) Request = t + type Absence (JSONRequestBody t) Request = Text + + toAttribute :: Request -> m (Result (JSONRequestBody t) Request) + toAttribute r = do + chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk r + pure $ case eitherDecode' (fromChunks chunks) of + Left e -> NotFound (pack e) + Right t -> Found t + -- | A middleware to parse the request body as JSON and convert it to -- a value via a 'FromJSON' instance. -- @@ -32,17 +46,14 @@ -- -- > jsonRequestBody @t handler -- -jsonRequestBody :: forall t m req res a. (FromJSON t, MonadRouter m, MonadIO m) - => RequestMiddleware m req (JSONRequestBody t:req) res a +-- Returns a 400 Bad Request response on failure to parse body. +jsonRequestBody :: forall t m req a. (FromJSON t, MonadRouter m, MonadIO m) + => RequestMiddleware' m req (JSONRequestBody t:req) a jsonRequestBody handler = Kleisli $ - linkplus @(JSONRequestBody t) >=> either (failHandler . mkError) (runKleisli handler) + probe @(JSONRequestBody t) >=> either (errorResponse . mkError) (runKleisli handler) where mkError :: Text -> Response ByteString - mkError e = Response - { respStatus = badRequest400 - , respHeaders = fromList [] - , respBody = Just $ fromStrict $ encodeUtf8 $ "Error parsing request body: " <> e - } + mkError e = badRequest400 $ fromStrict $ encodeUtf8 $ "Error parsing request body: " <> e -- | A middleware that converts the response that has a 'ToJSON' -- instance to a 'ByteString' response. @@ -54,11 +65,7 @@ -- -- > jsonResponseBody @t handler -- -jsonResponseBody :: (ToJSON t, Monad m) => Middleware m req req res '[] t ByteString +jsonResponseBody :: (ToJSON t, Monad m) => ResponseMiddleware' m req t ByteString jsonResponseBody handler = Kleisli $ \req -> do - x <- unlink <$> runKleisli handler req - pure $ linkzero $ Response - { respStatus = respStatus x - , respHeaders = insert hContentType "application/json" $ respHeaders x - , respBody = encode <$> respBody x - } + x <- runKleisli handler req + pure $ setResponseHeader hContentType "application/json" $ encode <$> x diff --git a/src/WebGear/Middlewares/Header.hs b/src/WebGear/Middlewares/Header.hs --- a/src/WebGear/Middlewares/Header.hs +++ b/src/WebGear/Middlewares/Header.hs @@ -4,44 +4,353 @@ -- Maintainer : rkaippully@gmail.com -- -- Middlewares related to HTTP headers. +-- module WebGear.Middlewares.Header - ( requestContentType + ( -- * Traits + Header + , Header' + , HeaderNotFound (..) + , HeaderParseError (..) + , HeaderMatch + , HeaderMatch' + , HeaderMismatch (..) + + -- * Middlewares + , header + , optionalHeader + , lenientHeader + , optionalLenientHeader + , headerMatch + , optionalHeaderMatch + , requestContentTypeHeader + , addResponseHeader ) where import Control.Arrow (Kleisli (..)) import Control.Monad ((>=>)) -import Data.ByteString.Lazy (ByteString) -import Data.HashMap.Strict (fromList) +import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) import Data.String (fromString) -import GHC.TypeLits (KnownSymbol) -import Network.HTTP.Types (badRequest400) +import Data.Text (Text) +import Data.Void (Void, absurd) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Network.HTTP.Types (HeaderName) import Text.Printf (printf) +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) -import WebGear.Route (MonadRouter (..)) -import WebGear.Trait (linkplus) -import WebGear.Trait.Header (HeaderMatch, HeaderMismatch (..)) -import WebGear.Types (RequestMiddleware, Response (..)) +import WebGear.Modifiers (Existence (..), ParseStyle (..)) +import WebGear.Trait (Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), + ResponseMiddleware', badRequest400, requestHeader, responseHeader, + setResponseHeader) +import qualified Data.ByteString.Lazy as LBS + +-- | A 'Trait' for capturing an HTTP header of specified @name@ and +-- converting it to some type @val@ via 'FromHttpApiData'. The +-- modifiers @e@ and @p@ determine how missing headers and parsing +-- errors are handled. The header name is compared case-insensitively. +data Header' (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) + +-- | A 'Trait' for capturing a header with name @name@ in a request or +-- response and convert it to some type @val@ via 'FromHttpApiData'. +type Header (name :: Symbol) (val :: Type) = Header' Required Strict name val + +-- | Indicates a missing header +data HeaderNotFound = HeaderNotFound + deriving stock (Read, Show, Eq) + +-- | Error in converting a header +newtype HeaderParseError = HeaderParseError Text + deriving stock (Read, Show, Eq) + +deriveRequestHeader :: (KnownSymbol name, FromHttpApiData val) + => Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r +deriveRequestHeader proxy req cont = + let s = fromString $ symbolVal proxy + in cont $ parseHeader <$> requestHeader s req + +deriveResponseHeader :: (KnownSymbol name, FromHttpApiData val) + => Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r +deriveResponseHeader proxy res cont = + let s = fromString $ symbolVal proxy + in cont $ parseHeader <$> responseHeader s res + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) Request m where + type Attribute (Header' Required Strict name val) Request = val + type Absence (Header' Required Strict name val) Request = Either HeaderNotFound HeaderParseError + + toAttribute :: Request -> m (Result (Header' Required Strict name val) Request) + toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case + Nothing -> NotFound (Left HeaderNotFound) + Just (Left e) -> NotFound (Right $ HeaderParseError e) + Just (Right x) -> Found x + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) Request m where + type Attribute (Header' Optional Strict name val) Request = Maybe val + type Absence (Header' Optional Strict name val) Request = HeaderParseError + + toAttribute :: Request -> m (Result (Header' Optional Strict name val) Request) + toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> NotFound $ HeaderParseError e + Just (Right x) -> Found (Just x) + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) Request m where + type Attribute (Header' Required Lenient name val) Request = Either Text val + type Absence (Header' Required Lenient name val) Request = HeaderNotFound + + toAttribute :: Request -> m (Result (Header' Required Lenient name val) Request) + toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case + Nothing -> NotFound HeaderNotFound + Just (Left e) -> Found (Left e) + Just (Right x) -> Found (Right x) + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) Request m where + type Attribute (Header' Optional Lenient name val) Request = Maybe (Either Text val) + type Absence (Header' Optional Lenient name val) Request = Void + + toAttribute :: Request -> m (Result (Header' Optional Lenient name val) Request) + toAttribute r = pure $ deriveRequestHeader (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> Found (Just (Left e)) + Just (Right x) -> Found (Just (Right x)) + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) (Response a) m where + type Attribute (Header' Required Strict name val) (Response a) = val + type Absence (Header' Required Strict name val) (Response a) = Either HeaderNotFound HeaderParseError + + toAttribute :: Response a -> m (Result (Header' Required Strict name val) (Response a)) + toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case + Nothing -> NotFound (Left HeaderNotFound) + Just (Left e) -> NotFound (Right $ HeaderParseError e) + Just (Right x) -> Found x + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) (Response a) m where + type Attribute (Header' Optional Strict name val) (Response a) = Maybe val + type Absence (Header' Optional Strict name val) (Response a) = HeaderParseError + + toAttribute :: Response a -> m (Result (Header' Optional Strict name val) (Response a)) + toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> NotFound $ HeaderParseError e + Just (Right x) -> Found (Just x) + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) (Response a) m where + type Attribute (Header' Required Lenient name val) (Response a) = Either Text val + type Absence (Header' Required Lenient name val) (Response a) = HeaderNotFound + + toAttribute :: Response a -> m (Result (Header' Required Lenient name val) (Response a)) + toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case + Nothing -> NotFound HeaderNotFound + Just (Left e) -> Found (Left e) + Just (Right x) -> Found (Right x) + + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) (Response a) m where + type Attribute (Header' Optional Lenient name val) (Response a) = Maybe (Either Text val) + type Absence (Header' Optional Lenient name val) (Response a) = () + + toAttribute :: Response a -> m (Result (Header' Optional Lenient name val) (Response a)) + toAttribute r = pure $ deriveResponseHeader (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> Found (Just (Left e)) + Just (Right x) -> Found (Just (Right x)) + + +-- | A 'Trait' for ensuring that an HTTP header with specified @name@ +-- has value @val@. The modifier @e@ determines how missing headers +-- are handled. The header name is compared case-insensitively. +data HeaderMatch' (e :: Existence) (name :: Symbol) (val :: Symbol) + +-- | A 'Trait' for ensuring that a header with a specified @name@ has +-- value @val@. +type HeaderMatch (name :: Symbol) (val :: Symbol) = HeaderMatch' Required name val + +-- | Failure in extracting a header value +data HeaderMismatch = HeaderMismatch + { expectedHeader :: ByteString + , actualHeader :: ByteString + } + deriving stock (Eq, Read, Show) + + +instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Required name val) Request m where + type Attribute (HeaderMatch' Required name val) Request = () + type Absence (HeaderMatch' Required name val) Request = Maybe HeaderMismatch + + toAttribute :: Request -> m (Result (HeaderMatch' Required name val) Request) + toAttribute r = pure $ + let + name = fromString $ symbolVal (Proxy @name) + expected = fromString $ symbolVal (Proxy @val) + in + case requestHeader name r of + Nothing -> NotFound Nothing + Just hv | hv == expected -> Found () + | otherwise -> NotFound $ Just HeaderMismatch {expectedHeader = expected, actualHeader = hv} + +instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Optional name val) Request m where + type Attribute (HeaderMatch' Optional name val) Request = Maybe () + type Absence (HeaderMatch' Optional name val) Request = HeaderMismatch + + toAttribute :: Request -> m (Result (HeaderMatch' Optional name val) Request) + toAttribute r = pure $ + let + name = fromString $ symbolVal (Proxy @name) + expected = fromString $ symbolVal (Proxy @val) + in + case requestHeader name r of + Nothing -> Found Nothing + Just hv | hv == expected -> Found (Just ()) + | otherwise -> NotFound HeaderMismatch {expectedHeader = expected, actualHeader = hv} + + +-- | A middleware to extract a header value and convert it to a value +-- of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > header @"Content-Length" @Integer handler +-- +-- The associated trait attribute has type @val@. A 400 Bad Request +-- response is returned if the header is not found or could not be +-- parsed. +header :: forall name val m req a. + (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (Header name val:req) a +header handler = Kleisli $ + probe @(Header name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + headerName :: String + headerName = symbolVal $ Proxy @name + + mkError :: Either HeaderNotFound HeaderParseError -> Response LBS.ByteString + mkError (Left HeaderNotFound) = badRequest400 $ fromString $ printf "Could not find header %s" headerName + mkError (Right (HeaderParseError _)) = badRequest400 $ fromString $ + printf "Invalid value for header %s" headerName + +-- | A middleware to extract a header value and convert it to a value +-- of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > optionalHeader @"Content-Length" @Integer handler +-- +-- The associated trait attribute has type @Maybe val@; a @Nothing@ +-- value indicates that the header is missing from the request. A 400 +-- Bad Request response is returned if the header could not be parsed. +optionalHeader :: forall name val m req a. + (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (Header' Optional Strict name val:req) a +optionalHeader handler = Kleisli $ + probe @(Header' Optional Strict name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + headerName :: String + headerName = symbolVal $ Proxy @name + + mkError :: HeaderParseError -> Response LBS.ByteString + mkError (HeaderParseError _) = badRequest400 $ fromString $ + printf "Invalid value for header %s" headerName + +-- | A middleware to extract a header value and convert it to a value +-- of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > lenientHeader @"Content-Length" @Integer handler +-- +-- The associated trait attribute has type @Either Text val@. A 400 +-- Bad Request reponse is returned if the header is missing. The +-- parsing is done leniently; the trait attribute is set to @Left +-- Text@ in case of parse errors or @Right val@ on success. +lenientHeader :: forall name val m req a. + (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (Header' Required Lenient name val:req) a +lenientHeader handler = Kleisli $ + probe @(Header' Required Lenient name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + headerName :: String + headerName = symbolVal $ Proxy @name + + mkError :: HeaderNotFound -> Response LBS.ByteString + mkError HeaderNotFound = badRequest400 $ fromString $ printf "Could not find header %s" headerName + +-- | A middleware to extract an optional header value and convert it +-- to a value of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > optionalLenientHeader @"Content-Length" @Integer handler +-- +-- The associated trait attribute has type @Maybe (Either Text +-- val)@. This middleware never fails. +optionalLenientHeader :: forall name val m req a. + (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (Header' Optional Lenient name val:req) a +optionalLenientHeader handler = Kleisli $ + probe @(Header' Optional Lenient name val) >=> either absurd (runKleisli handler) + +-- | A middleware to ensure that a header in the request has a +-- specific value. Fails the handler with a 400 Bad Request response +-- if the header does not exist or does not match. +headerMatch :: forall name val m req a. + (KnownSymbol name, KnownSymbol val, MonadRouter m) + => RequestMiddleware' m req (HeaderMatch name val:req) a +headerMatch handler = Kleisli $ + probe @(HeaderMatch name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + headerName :: String + headerName = symbolVal $ Proxy @name + + mkError :: Maybe HeaderMismatch -> Response LBS.ByteString + mkError Nothing = badRequest400 $ fromString $ printf "Could not find header %s" headerName + mkError (Just e) = badRequest400 $ fromString $ + printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e) + +-- | A middleware to ensure that an optional header in the request has +-- a specific value. Fails the handler with a 400 Bad Request response +-- if the header has a different value. +optionalHeaderMatch :: forall name val m req a. + (KnownSymbol name, KnownSymbol val, MonadRouter m) + => RequestMiddleware' m req (HeaderMatch' Optional name val:req) a +optionalHeaderMatch handler = Kleisli $ + probe @(HeaderMatch' Optional name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + headerName :: String + headerName = symbolVal $ Proxy @name + + mkError :: HeaderMismatch -> Response LBS.ByteString + mkError e = badRequest400 $ fromString $ + printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e) + -- | A middleware to check that the Content-Type header in the request -- has a specific value. It will fail the handler if the header did -- not match. -- --- Typical usage: +-- Example usage: -- --- > requestContentType @"application/json" handler +-- > requestContentTypeHeader @"application/json" handler -- -requestContentType :: forall c m req res a. (KnownSymbol c, MonadRouter m) - => RequestMiddleware m req (HeaderMatch "Content-Type" c:req) res a -requestContentType handler = Kleisli $ - linkplus @(HeaderMatch "Content-Type" c) >=> either (failHandler . mkError) (runKleisli handler) - where - mkError :: HeaderMismatch -> Response ByteString - mkError err = Response - { respStatus = badRequest400 - , respHeaders = fromList [] - , respBody = Just $ fromString $ - case (expectedHeader err, actualHeader err) of - (ex, Nothing) -> printf "Expected Content-Type header %s but not found" (show ex) - (ex, Just h) -> printf "Expected Content-Type header %s but found %s" (show ex) (show h) - } +requestContentTypeHeader :: forall val m req a. (KnownSymbol val, MonadRouter m) + => RequestMiddleware' m req (HeaderMatch "Content-Type" val:req) a +requestContentTypeHeader = headerMatch @"Content-Type" @val + +-- | A middleware to create or update a response header. +-- +-- Example usage: +-- +-- > addResponseHeader "Content-type" "application/json" handler +-- +addResponseHeader :: forall t m req a. (ToHttpApiData t, Monad m) + => HeaderName -> t -> ResponseMiddleware' m req a a +addResponseHeader name val handler = Kleisli $ runKleisli handler >=> pure . setResponseHeader name (toHeader val) diff --git a/src/WebGear/Middlewares/Method.hs b/src/WebGear/Middlewares/Method.hs --- a/src/WebGear/Middlewares/Method.hs +++ b/src/WebGear/Middlewares/Method.hs @@ -5,18 +5,71 @@ -- -- Middlewares related to HTTP methods. module WebGear.Middlewares.Method - ( method + ( Method + , IsStdMethod (..) + , MethodMismatch (..) + , method ) where import Control.Arrow (Kleisli (..)) import Control.Monad ((>=>)) +import Data.Proxy (Proxy (..)) -import WebGear.Route (MonadRouter (..)) -import WebGear.Trait (linkplus) -import WebGear.Trait.Method (IsStdMethod, Method) -import WebGear.Types (RequestMiddleware) +import WebGear.Trait (Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', requestMethod) +import qualified Network.HTTP.Types as HTTP + +-- | A 'Trait' for capturing the HTTP method of a request +data Method (t :: HTTP.StdMethod) + +-- | Failure to match method against an expected value +data MethodMismatch = MethodMismatch + { expectedMethod :: HTTP.Method + , actualMethod :: HTTP.Method + } + +instance (IsStdMethod t, Monad m) => Trait (Method t) Request m where + type Attribute (Method t) Request = () + type Absence (Method t) Request = MethodMismatch + + toAttribute :: Request -> m (Result (Method t) Request) + toAttribute r = + let + expected = HTTP.renderStdMethod $ toStdMethod $ Proxy @t + actual = requestMethod r + in + pure $ if expected == actual + then Found () + else NotFound $ MethodMismatch expected actual + + +-- | A typeclass to map a 'HTTP.StdMethod' from type level to term +-- level. +class IsStdMethod t where + -- | Convert @t@ to term level. + toStdMethod :: Proxy t -> HTTP.StdMethod + +instance IsStdMethod HTTP.GET where + toStdMethod = const HTTP.GET +instance IsStdMethod HTTP.POST where + toStdMethod = const HTTP.POST +instance IsStdMethod HTTP.HEAD where + toStdMethod = const HTTP.HEAD +instance IsStdMethod HTTP.PUT where + toStdMethod = const HTTP.PUT +instance IsStdMethod HTTP.DELETE where + toStdMethod = const HTTP.DELETE +instance IsStdMethod HTTP.TRACE where + toStdMethod = const HTTP.TRACE +instance IsStdMethod HTTP.CONNECT where + toStdMethod = const HTTP.CONNECT +instance IsStdMethod HTTP.OPTIONS where + toStdMethod = const HTTP.OPTIONS +instance IsStdMethod HTTP.PATCH where + toStdMethod = const HTTP.PATCH + -- | A middleware to check whether the request has a specified HTTP -- method. -- @@ -27,6 +80,6 @@ -- It is also idiomatic to use the template haskell quasiquoter -- 'WebGear.Middlewares.Path.match' in cases where both HTTP method -- and path needs to be matched. -method :: forall t m req res a. (IsStdMethod t, MonadRouter m) - => RequestMiddleware m req (Method t:req) res a -method handler = Kleisli $ linkplus @(Method t) >=> either (const rejectRoute) (runKleisli handler) +method :: forall t m req a. (IsStdMethod t, MonadRouter m) + => RequestMiddleware' m req (Method t:req) a +method handler = Kleisli $ probe @(Method t) >=> either (const rejectRoute) (runKleisli handler) diff --git a/src/WebGear/Middlewares/Params.hs b/src/WebGear/Middlewares/Params.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Middlewares/Params.hs @@ -0,0 +1,186 @@ +-- | +-- Copyright : (c) Raghu Kaippully, 2020 +-- License : MPL-2.0 +-- Maintainer : rkaippully@gmail.com +-- +-- Middlewares for handling query parameters +-- +module WebGear.Middlewares.Params + ( -- * Traits + QueryParam + , QueryParam' + , ParamNotFound (..) + , ParamParseError (..) + + -- * Middlewares + , queryParam + , optionalQueryParam + , lenientQueryParam + , optionalLenientQueryParam + ) where + +import Control.Arrow (Kleisli (..)) +import Control.Monad ((>=>)) +import Data.List (find) +import Data.Proxy (Proxy (..)) +import Data.String (fromString) +import Data.Text (Text) +import Data.Void (Void, absurd) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Network.HTTP.Types (queryToQueryText) +import Text.Printf (printf) +import Web.HttpApiData (FromHttpApiData (..)) + +import WebGear.Modifiers (Existence (..), ParseStyle (..)) +import WebGear.Trait (Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), badRequest400, + queryString) + +import qualified Data.ByteString.Lazy as LBS + + +-- | Capture a query parameter with a specified @name@ and convert it +-- to a value of type @val@ via 'FromHttpApiData'. +type QueryParam (name :: Symbol) val = QueryParam' Required Strict name val + +-- | Capture a query parameter with a specified @name@ and convert it +-- to a value of type @val@ via 'FromHttpApiData'. The type parameter +-- @e@ denotes whether the query parameter is required to be +-- present. The parse style parameter @p@ determines whether the +-- conversion is applied strictly or leniently. +data QueryParam' (e :: Existence) (p :: ParseStyle) (name :: Symbol) val + +-- | Indicates a missing query parameter +data ParamNotFound = ParamNotFound + deriving stock (Read, Show, Eq) + +-- | Error in converting a query parameter +newtype ParamParseError = ParamParseError Text + deriving stock (Read, Show, Eq) + +deriveRequestParam :: (KnownSymbol name, FromHttpApiData val) + => Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r +deriveRequestParam proxy req cont = + let name = fromString $ symbolVal proxy + params = queryToQueryText $ queryString req + in cont $ parseQueryParam <$> (find ((== name) . fst) params >>= snd) + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Strict name val) Request m where + type Attribute (QueryParam' Required Strict name val) Request = val + type Absence (QueryParam' Required Strict name val) Request = Either ParamNotFound ParamParseError + + toAttribute :: Request -> m (Result (QueryParam' Required Strict name val) Request) + toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case + Nothing -> NotFound (Left ParamNotFound) + Just (Left e) -> NotFound (Right $ ParamParseError e) + Just (Right x) -> Found x + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Strict name val) Request m where + type Attribute (QueryParam' Optional Strict name val) Request = Maybe val + type Absence (QueryParam' Optional Strict name val) Request = ParamParseError + + toAttribute :: Request -> m (Result (QueryParam' Optional Strict name val) Request) + toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> NotFound $ ParamParseError e + Just (Right x) -> Found (Just x) + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Lenient name val) Request m where + type Attribute (QueryParam' Required Lenient name val) Request = Either Text val + type Absence (QueryParam' Required Lenient name val) Request = ParamNotFound + + toAttribute :: Request -> m (Result (QueryParam' Required Lenient name val) Request) + toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case + Nothing -> NotFound ParamNotFound + Just (Left e) -> Found (Left e) + Just (Right x) -> Found (Right x) + +instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Lenient name val) Request m where + type Attribute (QueryParam' Optional Lenient name val) Request = Maybe (Either Text val) + type Absence (QueryParam' Optional Lenient name val) Request = Void + + toAttribute :: Request -> m (Result (QueryParam' Optional Lenient name val) Request) + toAttribute r = pure $ deriveRequestParam (Proxy @name) r $ \case + Nothing -> Found Nothing + Just (Left e) -> Found (Just (Left e)) + Just (Right x) -> Found (Just (Right x)) + + +-- | A middleware to extract a query parameter and convert it to a +-- value of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > queryParam @"limit" @Int handler +-- +-- The associated trait attribute has type @val@. This middleware will +-- respond with a 400 Bad Request response if the query parameter is +-- not found or could not be parsed. +queryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (QueryParam name val:req) a +queryParam handler = Kleisli $ probe @(QueryParam name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + paramName :: String + paramName = symbolVal $ Proxy @name + + mkError :: Either ParamNotFound ParamParseError -> Response LBS.ByteString + mkError err = badRequest400 $ fromString $ + case err of + Left ParamNotFound -> printf "Could not find query parameter %s" paramName + Right (ParamParseError _) -> printf "Invalid value for query parameter %s" paramName + +-- | A middleware to extract an optional query parameter and convert +-- it to a value of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > optionalQueryParam @"limit" @Int handler +-- +-- The associated trait attribute has type @Maybe val@; a @Nothing@ +-- value indicates a missing param. A 400 Bad Request response is +-- returned if the query parameter could not be parsed. +optionalQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (QueryParam' Optional Strict name val:req) a +optionalQueryParam handler = Kleisli $ probe @(QueryParam' Optional Strict name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + paramName :: String + paramName = symbolVal $ Proxy @name + + mkError :: ParamParseError -> Response LBS.ByteString + mkError _ = badRequest400 $ fromString $ printf "Invalid value for query parameter %s" paramName + +-- | A middleware to extract a query parameter and convert it to a +-- value of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > lenientQueryParam @"limit" @Int handler +-- +-- The associated trait attribute has type @Either Text val@. A 400 +-- Bad Request reponse is returned if the query parameter is +-- missing. The parsing is done leniently; the trait attribute is set +-- to @Left Text@ in case of parse errors or @Right val@ on success. +lenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (QueryParam' Required Lenient name val:req) a +lenientQueryParam handler = Kleisli $ + probe @(QueryParam' Required Lenient name val) >=> either (errorResponse . mkError) (runKleisli handler) + where + paramName :: String + paramName = symbolVal $ Proxy @name + + mkError :: ParamNotFound -> Response LBS.ByteString + mkError ParamNotFound = badRequest400 $ fromString $ printf "Could not find query parameter %s" paramName + +-- | A middleware to extract an optional query parameter and convert it +-- to a value of type @val@ using 'FromHttpApiData'. +-- +-- Example usage: +-- +-- > optionalLenientHeader @"Content-Length" @Integer handler +-- +-- The associated trait attribute has type @Maybe (Either Text +-- val)@. This middleware never fails. +optionalLenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m req (QueryParam' Optional Lenient name val:req) a +optionalLenientQueryParam handler = Kleisli $ + probe @(QueryParam' Optional Lenient name val) >=> either absurd (runKleisli handler) diff --git a/src/WebGear/Middlewares/Path.hs b/src/WebGear/Middlewares/Path.hs --- a/src/WebGear/Middlewares/Path.hs +++ b/src/WebGear/Middlewares/Path.hs @@ -5,30 +5,103 @@ -- -- Middlewares related to route paths. module WebGear.Middlewares.Path - ( path + ( Path + , PathVar + , PathVarError (..) + , PathEnd + , path , pathVar + , pathEnd , match + , route ) where import Control.Arrow (Kleisli (..)) import Control.Monad ((>=>)) +import Control.Monad.State.Strict (MonadState (..)) +import Data.Foldable (toList) import Data.Function ((&)) -import Data.List.NonEmpty (NonEmpty (..), toList) -import GHC.TypeLits (KnownSymbol) +import Data.List.NonEmpty (NonEmpty (..), filter) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName) -import Web.HttpApiData (FromHttpApiData) +import Prelude hiding (drop, filter, take) +import Web.HttpApiData (FromHttpApiData (..)) import WebGear.Middlewares.Method (method) -import WebGear.Route (MonadRouter (..)) -import WebGear.Trait (linkplus) -import WebGear.Trait.Path (Path, PathVar) -import WebGear.Types (RequestMiddleware) +import WebGear.Trait (Result (..), Trait (..), probe) +import WebGear.Types (MonadRouter (..), PathInfo (..), Request, RequestMiddleware') import WebGear.Util (splitOn) import qualified Data.List as List +-- | A path component which is literally matched against the request +-- but discarded after that. +data Path (s :: Symbol) + +instance (KnownSymbol s, MonadState PathInfo m) => Trait (Path s) Request m where + type Attribute (Path s) Request = () + type Absence (Path s) Request = () + + toAttribute :: Request -> m (Result (Path s) Request) + toAttribute _ = do + PathInfo actualPath <- get + case List.stripPrefix expectedPath actualPath of + Nothing -> pure $ NotFound () + Just rest -> do + put $ PathInfo rest + pure $ Found () + + where + expectedPath = Proxy @s + & symbolVal + & splitOn '/' + & filter (/= "") + & map pack + + +-- | A path variable that is extracted and converted to a value of +-- type @val@. The @tag@ is usually a type-level symbol (string) to +-- uniquely identify this variable. +data PathVar tag val + +-- | Failure to extract a 'PathVar' +data PathVarError = PathVarNotFound | PathVarParseError Text + deriving (Eq, Show, Read) + +instance (FromHttpApiData val, MonadState PathInfo m) => Trait (PathVar tag val) Request m where + type Attribute (PathVar tag val) Request = val + type Absence (PathVar tag val) Request = PathVarError + + toAttribute :: Request -> m (Result (PathVar tag val) Request) + toAttribute _ = do + PathInfo actualPath <- get + case actualPath of + [] -> pure $ NotFound PathVarNotFound + (x:xs) -> case parseUrlPiece @val x of + Left e -> pure $ NotFound $ PathVarParseError e + Right v -> do + put $ PathInfo xs + pure $ Found v + +-- | Trait to indicate that no more path components are present in the request +data PathEnd + +instance MonadState PathInfo m => Trait PathEnd Request m where + type Attribute PathEnd Request = () + type Absence PathEnd Request = () + + toAttribute :: Request -> m (Result PathEnd Request) + toAttribute _ = do + PathInfo actualPath <- get + pure $ if null actualPath + then Found () + else NotFound () + + -- | A middleware that literally matches path @s@. -- -- The symbol @s@ could contain one or more parts separated by a @@ -40,10 +113,10 @@ -- -- > path @"a/b/c" handler -- -path :: forall s ts res m a. (KnownSymbol s, MonadRouter m) - => RequestMiddleware m ts (Path s:ts) res a +path :: forall s ts m a. (KnownSymbol s, MonadRouter m) + => RequestMiddleware' m ts (Path s:ts) a path handler = Kleisli $ - linkplus @(Path s) >=> either (const rejectRoute) (runKleisli handler) + probe @(Path s) >=> either (const rejectRoute) (runKleisli handler) -- | A middleware that captures a path variable from a single path -- component. @@ -58,52 +131,101 @@ -- -- > pathVar @"objId" @Int handler -- -pathVar :: forall tag val ts res m a. (FromHttpApiData val, MonadRouter m) - => RequestMiddleware m ts (PathVar tag val:ts) res a +pathVar :: forall tag val ts m a. (FromHttpApiData val, MonadRouter m) + => RequestMiddleware' m ts (PathVar tag val:ts) a pathVar handler = Kleisli $ - linkplus @(PathVar tag val) >=> either (const rejectRoute) (runKleisli handler) + probe @(PathVar tag val) >=> either (const rejectRoute) (runKleisli handler) --- | Produces middleware(s) to match an optional HTTP method and path. +-- | A middleware that verifies that end of path is reached. +pathEnd :: MonadRouter m => RequestMiddleware' m ts (PathEnd:ts) a +pathEnd handler = Kleisli $ + probe @PathEnd >=> either (const rejectRoute) (runKleisli handler) + +-- | Produces middleware(s) to match an optional HTTP method and some +-- path components. -- +-- This middleware matches a prefix of path components, the remaining +-- components can be matched by subsequent uses of 'match'. +-- -- This quasiquoter can be used in several ways: -- --- * @[match|a\/b\/c]@ is equivalent to @'path' \@\"a\/b\/c\"@ --- * @[match|a\/b\/objId:Int\/d]@ is equivalent to --- @'path' \@\"a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' @\"d\"@ --- * @[match|GET a\/b\/c]@ is equivalent to --- @'method' \@GET $ 'path' \@\"a\/b\/c\"@ --- * @[match|GET a\/b\/objId:Int\/d]@ is equivalent to --- @'method' \@GET . 'path' \@\"a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@ +-- +---------------------------------------+---------------------------------------------------------------------------------------+ +-- | QuasiQuoter | Equivalent Middleware | +-- +=======================================+=======================================================================================+ +-- | @[match| \/a\/b\/c |]@ | @'path' \@\"\/a\/b\/c\"@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------+ +-- | @[match| \/a\/b\/objId:Int\/d |]@ | @'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------+ +-- | @[match| GET \/a\/b\/c |]@ | @'method' \@GET . 'path' \@\"\/a\/b\/c\"@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------+ +-- | @[match| GET \/a\/b\/objId:Int\/d |]@ | @'method' \@GET . 'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------+ -- match :: QuasiQuoter match = QuasiQuoter - { quoteExp = toExp + { quoteExp = toMatchExp , quotePat = const $ fail "match cannot be used in a pattern" , quoteType = const $ fail "match cannot be used in a type" , quoteDec = const $ fail "match cannot be used in a declaration" } - where - toExp :: String -> Q Exp - toExp s = case List.words s of - [m, p] -> do - let methodExp = AppTypeE (VarE 'method) (ConT $ mkName m) - pathExps <- toPathExps p - pure $ List.foldr1 compose $ methodExp :| pathExps - [p] -> do - pathExps <- toPathExps p - pure $ List.foldr1 compose pathExps - _ -> fail "match expects an HTTP method and a path or just a path" +-- | Produces middleware(s) to match an optional HTTP method and the +-- entire request path. +-- +-- This middleware is intended to be used in cases where the entire +-- path needs to be matched. Use 'match' middleware to match only an +-- initial portion of the path. +-- +-- This quasiquoter can be used in several ways: +-- +-- +---------------------------------------+---------------------------------------------------------------------------------------------------+ +-- | QuasiQuoter | Equivalent Middleware | +-- +=======================================+===================================================================================================+ +-- | @[route| \/a\/b\/c |]@ | @'path' \@\"\/a\/b\/c\" . 'pathEnd'@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------------------+ +-- | @[route| \/a\/b\/objId:Int\/d |]@ | @'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\" . 'pathEnd'@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------------------+ +-- | @[route| GET \/a\/b\/c |]@ | @'method' \@GET . 'path' \@\"\/a\/b\/c\" . 'pathEnd'@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------------------+ +-- | @[route| GET \/a\/b\/objId:Int\/d |]@ | @'method' \@GET . 'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\" . 'pathEnd'@ | +-- +---------------------------------------+---------------------------------------------------------------------------------------------------+ +-- +route :: QuasiQuoter +route = QuasiQuoter + { quoteExp = toRouteExp + , quotePat = const $ fail "route cannot be used in a pattern" + , quoteType = const $ fail "route cannot be used in a type" + , quoteDec = const $ fail "route cannot be used in a declaration" + } + +toRouteExp :: String -> Q Exp +toRouteExp s = do + e <- toMatchExp s + pure $ compose e (VarE 'pathEnd) + +toMatchExp :: String -> Q Exp +toMatchExp s = case List.words s of + [m, p] -> do + let methodExp = AppTypeE (VarE 'method) (ConT $ mkName m) + pathExps <- toPathExps p + pure $ List.foldr1 compose $ methodExp :| pathExps + [p] -> do + pathExps <- toPathExps p + pure $ List.foldr1 compose pathExps + _ -> fail "Expected an HTTP method and a path or just a path" + + where toPathExps :: String -> Q [Exp] toPathExps p = splitOn '/' p + & filter (/= "") & fmap (splitOn ':') & List.foldr joinPath [] & fmap toPathExp & sequence joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String] - joinPath s [] = [s] - joinPath (s:|[]) ((s':|[]) : xs) = ((s <> "/" <> s') :| []) : xs + joinPath p [] = [p] + joinPath (p:|[]) ((p':|[]) : xs) = ((p <> "/" <> p') :| []) : xs joinPath y (x:xs) = y:x:xs toPathExp :: NonEmpty String -> Q Exp @@ -111,5 +233,5 @@ toPathExp (v :| [t]) = pure $ AppTypeE (AppTypeE (VarE 'pathVar) (LitT $ StrTyLit v)) (ConT $ mkName t) toPathExp xs = fail $ "Invalid path component: " <> List.intercalate ":" (toList xs) - compose :: Exp -> Exp -> Exp - compose l = UInfixE l (VarE $ mkName ".") +compose :: Exp -> Exp -> Exp +compose l = UInfixE l (VarE $ mkName ".") diff --git a/src/WebGear/Modifiers.hs b/src/WebGear/Modifiers.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Modifiers.hs @@ -0,0 +1,18 @@ +-- | +-- Copyright : (c) Raghu Kaippully, 2020 +-- License : MPL-2.0 +-- Maintainer : rkaippully@gmail.com +-- +module WebGear.Modifiers + ( Existence (..) + , ParseStyle (..) + ) where + + +-- | Modifier used to indicate whether a trait is required or +-- optional. +data Existence = Required | Optional + +-- | Modifier used to indicate whether a trait is parsed strictly or +-- leniently. +data ParseStyle = Strict | Lenient diff --git a/src/WebGear/Route.hs b/src/WebGear/Route.hs deleted file mode 100644 --- a/src/WebGear/Route.hs +++ /dev/null @@ -1,81 +0,0 @@ --- | --- Copyright : (c) Raghu Kaippully, 2020 --- License : MPL-2.0 --- Maintainer : rkaippully@gmail.com --- --- Types and functions to route HTTP requests. -module WebGear.Route - ( RouterT - , MonadRouter (..) - , runRoute - ) where - -import Control.Applicative (Alternative) -import Control.Arrow (Kleisli (..)) -import Control.Monad (MonadPlus (..)) -import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) -import Data.ByteString.Lazy (ByteString) -import Data.HashMap.Strict (fromList) -import Data.Semigroup (First (..)) -import Data.String (fromString) -import Data.Version (showVersion) -import Network.HTTP.Types (Header, hServer, notFound404) - -import Paths_webgear_server (version) -import WebGear.Trait (linkzero, unlink) -import WebGear.Types (Handler, Response (..), waiResponse) - -import qualified Network.Wai as Wai - - --- | The monad transformer stack for routing. --- --- * The 'ExceptT' provides short-circuiting behaviour for --- 'rejectRoute' and 'failHandler'. --- --- * In case of 'rejectRoute', a 'Nothing' value is returned and in --- case of 'failHandler', a @Response ByteString@ is returned. --- --- * The 'First' wrapper is provided to get instances of 'Alternative' --- and 'MonadPlus' for 'RouterT'. --- -type RouterT m = ExceptT (Maybe (First (Response ByteString))) m - --- | HTTP request routing with short circuiting behavior. -class (Alternative m, MonadPlus m) => MonadRouter m where - -- | Mark the current route as rejected, alternatives can be tried - rejectRoute :: m a - - -- | Short-circuit the current handler and return a response - failHandler :: Response ByteString -> m a - -instance Monad m => MonadRouter (RouterT m) where - rejectRoute :: RouterT m a - rejectRoute = mzero - - failHandler :: Response ByteString -> RouterT m a - failHandler = throwError . Just . First - --- | Convert a routable handler into a plain function. --- --- This function is typically used to convert WebGear routes to a --- 'Wai.Application'. -runRoute :: Monad m - => Handler (RouterT m) '[] res ByteString - -> (Wai.Request -> m Wai.Response) -runRoute route req = waiResponse . addServerHeader . either (maybe notFoundResponse getFirst) id <$> runExceptT f - where - f = unlink <$> runKleisli route (linkzero req) - - notFoundResponse :: Response ByteString - notFoundResponse = Response - { respStatus = notFound404 - , respHeaders = fromList [] - , respBody = Just "Not Found" - } - - addServerHeader :: Response ByteString -> Response ByteString - addServerHeader r = r { respHeaders = respHeaders r <> fromList [serverHeader] } - - serverHeader :: Header - serverHeader = (hServer, fromString $ "WebGear/" ++ showVersion version) diff --git a/src/WebGear/Trait.hs b/src/WebGear/Trait.hs --- a/src/WebGear/Trait.hs +++ b/src/WebGear/Trait.hs @@ -4,133 +4,152 @@ -- License : MPL-2.0 -- Maintainer : rkaippully@gmail.com -- --- Traits are optional attributes that a value might posess. For example, --- a list containing totally ordered values might have a @Maximum@ trait --- where the associated attribute is the maximum value. The trait exists --- only if the list is non-empty. +-- Traits are optional attributes associated with a value. For +-- example, a list containing totally ordered values might have a +-- @Maximum@ trait where the associated attribute is the maximum +-- value. This trait exists only if the list is non-empty. The 'Trait' +-- typeclass provides an interface to extract such trait attributes. -- --- Traits help to access these attributes in a type-safe manner. +-- Traits help to link attributes with values in a type-safe manner. -- -- Traits are somewhat similar to [refinement -- types](https://hackage.haskell.org/package/refined), but allow --- arbitrary attributes to be associated with a value instead of only a --- predicate. +-- arbitrary attributes to be associated with a value instead of only +-- a predicate. +-- module WebGear.Trait ( -- * Core Types Trait (..) - , CheckResult (..) + , Result (..) , Linked - , Traits - -- * Linking values with traits - , linkzero - , linkplus - , linkminus + -- * Linking values with attributes + , link , unlink + , probe + , remove -- * Retrive trait attributes from linked values , Has (..) , Have + + , MissingTrait ) where import Data.Kind (Constraint, Type) -import Data.Tagged (Tagged (..)) +import Data.Proxy (Proxy (..)) +import GHC.TypeLits (ErrorMessage (..), TypeError) --- | A 'Trait' is an optional attribute @t@ associated with a value @a@. --- --- The 'check' function validates the presence of the trait for a --- given value. Checking the presence of the trait can optionally --- modify the value as well. +-- | A trait is an optional attribute @t@ associated with a value +-- @a@. class Monad m => Trait t a m where - -- | Type of the associated attribute - type Val t a + -- | Type of the associated attribute when the trait holds for a + -- value + type Attribute t a :: Type - -- | Type of check failures - type Fail t a + -- | Type that indicates that the trait does not exist for a + -- value. This could be an error message, parse error etc. + type Absence t a :: Type - -- | Checks the presence of the associated attribute. - check :: a -> m (CheckResult t a) + -- | Attempt to deduce the trait attribute from the value @a@. It is + -- possible that deducing a trait's presence can alter the value, + -- hence this function returns a possibly updated value along with + -- the trait attribute on success. + toAttribute :: a -> m (Result t a) --- | Result of a 'check' operation -data CheckResult t a = CheckSuccess a (Val t a) - | CheckFail (Fail t a) -deriving instance (Eq a, Eq (Val t a), Eq (Fail t a)) => Eq (CheckResult t a) -deriving instance (Show a, Show (Val t a), Show (Fail t a)) => Show (CheckResult t a) -deriving instance (Read a, Read (Val t a), Read (Fail t a)) => Read (CheckResult t a) - +-- | The result of 'toAttribute' - either a successful deduction of an +-- attribute or an error. +data Result t a = NotFound (Absence t a) + | Found (Attribute t a) --- | A trivial trait that is always present and whose attribute does --- not carry any meaningful information. +-- | A trivial derivable trait that is always present and whose +-- attribute does not carry any meaningful information. instance Monad m => Trait '[] a m where - type Val '[] a = () - type Fail '[] a = () + type Attribute '[] a = () + type Absence '[] a = () - check :: a -> m (CheckResult '[] a) - check a = pure $ CheckSuccess a () + toAttribute :: a -> m (Result '[] a) + toAttribute = const $ pure $ Found () --- | Combination of many traits all of which are present for a value. -instance (Trait t a m, Trait ts a m) => Trait (t:ts) a m where - type Val (t:ts) a = (Val t a, Val ts a) - type Fail (t:ts) a = Either (CheckResult t a) (CheckResult ts a) +-- | Combination of many derivable traits all of which are present for +-- a value. +instance (Trait t a m, Trait ts a m, Monad m) => Trait (t:ts) a m where + type Attribute (t:ts) a = (Attribute t a, Attribute ts a) + type Absence (t:ts) a = Either (Result t a) (Result ts a) - check :: a -> m (CheckResult (t:ts) a) - check a = check @t a >>= \case - e@(CheckFail _) -> pure $ CheckFail $ Left e - CheckSuccess a' l -> check @ts a' >>= \case - e@(CheckFail _) -> pure $ CheckFail $ Right e - CheckSuccess a'' r -> pure $ CheckSuccess a'' (l, r) + toAttribute :: a -> m (Result (t:ts) a) + toAttribute a = toAttribute @t a >>= \case + e@(NotFound _) -> pure $ NotFound $ Left e + Found l -> toAttribute @ts a >>= \case + e@(NotFound _) -> pure $ NotFound $ Right e + Found r -> pure $ Found (l, r) --- | Constraint for functions that use multiple traits -type family Traits ts a m :: Constraint where - Traits '[] a m = () - Traits (t:ts) a m = (Trait t a m, Traits ts a m) -- | A value linked with a type-level list of traits. data Linked (ts :: [Type]) a = Linked - { linkVal :: !(Val ts a) - , unlink :: !a -- ^ Retrive the value from a linked value + { linkAttribute :: !(Attribute ts a) + , unlink :: !a -- ^ Retrive the value from a linked value } --- | Link a value with the trivial trait -linkzero :: a -> Linked '[] a -linkzero = Linked () +-- | Wrap a value with an empty list of traits. +link :: a -> Linked '[] a +link = Linked () -- | Attempt to link an additional trait with an already linked value -linkplus :: Trait t a m => Linked ts a -> m (Either (Fail t a) (Linked (t:ts) a)) -linkplus l = do - v <- check (unlink l) +-- via the 'toAttribute' operation. This can fail indicating an +-- 'Absence' of the trait. +probe :: forall t ts a m. Trait t a m + => Linked ts a + -> m (Either (Absence t a) (Linked (t:ts) a)) +probe l = do + v <- toAttribute @t (unlink l) pure $ mkLinked v l where - mkLinked :: CheckResult t a -> Linked ts a -> Either (Fail t a) (Linked (t:ts) a) - mkLinked (CheckSuccess a left) lv = Right $ Linked (left, linkVal lv) a - mkLinked (CheckFail e) _ = Left e + mkLinked :: Result t a -> Linked ts a -> Either (Absence t a) (Linked (t:ts) a) + mkLinked (Found left) lv = Right $ Linked (left, linkAttribute lv) (unlink lv) + mkLinked (NotFound e) _ = Left e --- | Remove the leading trait from the linked value -linkminus :: Linked (t:ts) a -> Linked ts a -linkminus l = Linked (snd $ linkVal l) (unlink l) +-- | Remove the leading trait from the type-level list of traits +remove :: Linked (t:ts) a -> Linked ts a +remove l = Linked (snd $ linkAttribute l) (unlink l) --- | Constraint that proves that the trait @t@ is present somewhere in --- the list of traits @ts@. +-- | Constraint that proves that the trait @t@ is present in the list +-- of traits @ts@. class Has t ts where - traitValue :: Linked ts a -> Tagged t (Val t a) + -- | Get the attribute associated with @t@ from a linked value + get :: Proxy t -> Linked ts a -> Attribute t a instance Has t (t:ts) where - traitValue :: Linked (t : ts) a -> Tagged t (Val t a) - traitValue (Linked (lv, _) _) = Tagged lv + get :: Proxy t -> Linked (t:ts) a -> Attribute t a + get _ (Linked (lv, _) _) = lv instance {-# OVERLAPPABLE #-} Has t ts => Has t (t':ts) where - traitValue :: Linked (t':ts) a -> Tagged t (Val t a) - traitValue l = traitValue (rightLinked l) + get :: Proxy t -> Linked (t':ts) a -> Attribute t a + get _ l = get (Proxy @t) (rightLinked l) where rightLinked :: Linked (q:qs) b -> Linked qs b rightLinked (Linked (_, rv) a) = Linked rv a +-- For better type errors +instance TypeError (MissingTrait t) => Has t '[] where + get = undefined +-- | Type error for nicer UX of missing traits +type MissingTrait t = Text "The request doesn't have the trait ‘" :<>: ShowType t :<>: Text "’." + :$$: Text "" + :$$: Text "Did you use a wrong trait type?" + :$$: Text "For e.g., ‘PathVar \"foo\" Int’ instead of ‘PathVar \"foo\" String’?" + :$$: Text "" + :$$: Text "Or did you forget to apply an appropriate middleware?" + :$$: Text "For e.g. The trait ‘JSONRequestBody Foo’ can be used with ‘jsonRequestBody @Foo’ middleware." + :$$: Text "" + + -- | Constraint that proves that all the traits in the list @ts@ are --- present in the list @qs@. +-- also present in the list @qs@. type family Have ts qs :: Constraint where Have '[] qs = () Have (t:ts) qs = (Has t qs, Have ts qs) diff --git a/src/WebGear/Trait/Body.hs b/src/WebGear/Trait/Body.hs deleted file mode 100644 --- a/src/WebGear/Trait/Body.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- Copyright : (c) Raghu Kaippully, 2020 --- License : MPL-2.0 --- Maintainer : rkaippully@gmail.com --- --- Traits related to HTTP body. -module WebGear.Trait.Body - ( JSONRequestBody - ) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (FromJSON, eitherDecode') -import Data.ByteString.Lazy (fromChunks) -import Data.Kind (Type) -import Data.Text (Text, pack) - -import WebGear.Trait (CheckResult (..), Trait (..)) -import WebGear.Types (Request, getRequestBodyChunk) -import WebGear.Util (takeWhileM) - - --- | A 'Trait' for converting a JSON request body into a value. -data JSONRequestBody (t :: Type) - -instance (FromJSON t, MonadIO m) => Trait (JSONRequestBody t) Request m where - type Val (JSONRequestBody t) Request = t - type Fail (JSONRequestBody t) Request = Text - - check :: Request -> m (CheckResult (JSONRequestBody t) Request) - check r = do - chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk r - pure $ case eitherDecode' (fromChunks chunks) of - Left e -> CheckFail (pack e) - Right t -> CheckSuccess r t diff --git a/src/WebGear/Trait/Header.hs b/src/WebGear/Trait/Header.hs deleted file mode 100644 --- a/src/WebGear/Trait/Header.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | --- Copyright : (c) Raghu Kaippully, 2020 --- License : MPL-2.0 --- Maintainer : rkaippully@gmail.com --- --- Traits related to HTTP headers. -module WebGear.Trait.Header - ( Header - , HeaderFail (..) - , HeaderMatch - , HeaderMismatch (..) - ) where - -import Data.ByteString (ByteString) -import Data.Kind (Type) -import Data.Proxy (Proxy (..)) -import Data.String (fromString) -import Data.Text (Text) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Web.HttpApiData (FromHttpApiData (..)) - -import WebGear.Trait (CheckResult (..), Trait (..)) -import WebGear.Types (Request, requestHeader) - - --- | A 'Trait' for capturing a header with name @s@ in a request or --- response and convert it to some type @t@ via 'FromHttpApiData'. -data Header (s :: Symbol) (t :: Type) - --- | Failure in extracting a header value -data HeaderFail = HeaderNotFound | HeaderParseError Text - deriving stock (Read, Show, Eq) - -instance (KnownSymbol s, FromHttpApiData t, Monad m) => Trait (Header s t) Request m where - type Val (Header s t) Request = t - type Fail (Header s t) Request = HeaderFail - - check :: Request -> m (CheckResult (Header s t) Request) - check r = pure $ - let s = fromString $ symbolVal (Proxy @s) - in case parseHeader <$> requestHeader s r of - Nothing -> CheckFail HeaderNotFound - Just (Left e) -> CheckFail $ HeaderParseError e - Just (Right x) -> CheckSuccess r x - --- | A 'Trait' for ensuring that a header named @s@ has value @t@. -data HeaderMatch (s :: Symbol) (t :: Symbol) - --- | Failure in extracting a header value -data HeaderMismatch = HeaderMismatch - { expectedHeader :: ByteString - , actualHeader :: Maybe ByteString - } - deriving stock (Eq, Read, Show) - -instance (KnownSymbol s, KnownSymbol t, Monad m) => Trait (HeaderMatch s t) Request m where - type Val (HeaderMatch s t) Request = ByteString - type Fail (HeaderMatch s t) Request = HeaderMismatch - - check :: Request -> m (CheckResult (HeaderMatch s t) Request) - check r = pure $ - let - name = fromString $ symbolVal (Proxy @s) - expected = fromString $ symbolVal (Proxy @t) - in - case requestHeader name r of - Nothing -> CheckFail HeaderMismatch - {expectedHeader = expected, actualHeader = Nothing} - Just hv | hv == expected -> CheckSuccess r hv - | otherwise -> CheckFail HeaderMismatch - {expectedHeader = expected, actualHeader = Just hv} diff --git a/src/WebGear/Trait/Method.hs b/src/WebGear/Trait/Method.hs deleted file mode 100644 --- a/src/WebGear/Trait/Method.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | --- Copyright : (c) Raghu Kaippully, 2020 --- License : MPL-2.0 --- Maintainer : rkaippully@gmail.com --- --- Trait capturing the HTTP method in a request. -module WebGear.Trait.Method - ( Method - , IsStdMethod (..) - , MethodMismatch (..) - ) where - -import Data.Proxy (Proxy (..)) - -import WebGear.Trait (CheckResult (..), Trait (..)) -import WebGear.Types (Request, requestMethod) - -import qualified Network.HTTP.Types as HTTP - - --- | A 'Trait' for capturing the HTTP method of a request -data Method (t :: HTTP.StdMethod) - --- | Failure to match method against an expected value -data MethodMismatch = MethodMismatch - { expectedMethod :: HTTP.Method - , actualMethod :: HTTP.Method - } - -instance (Monad m, IsStdMethod t) => Trait (Method t) Request m where - type Val (Method t) Request = HTTP.Method - type Fail (Method t) Request = MethodMismatch - - check :: Request -> m (CheckResult (Method t) Request) - check r = - let - expected = HTTP.renderStdMethod $ toStdMethod $ Proxy @t - actual = requestMethod r - in - pure $ if expected == actual - then CheckSuccess r actual - else CheckFail $ MethodMismatch expected actual - - --- | A typeclass implemented by all 'HTTP.StdMethod's to convert them --- from type level to term level. -class IsStdMethod t where - -- | Convert @t@ to term level. - toStdMethod :: Proxy t -> HTTP.StdMethod - -instance IsStdMethod HTTP.GET where - toStdMethod = const HTTP.GET -instance IsStdMethod HTTP.POST where - toStdMethod = const HTTP.POST -instance IsStdMethod HTTP.HEAD where - toStdMethod = const HTTP.HEAD -instance IsStdMethod HTTP.PUT where - toStdMethod = const HTTP.PUT -instance IsStdMethod HTTP.DELETE where - toStdMethod = const HTTP.DELETE -instance IsStdMethod HTTP.TRACE where - toStdMethod = const HTTP.TRACE -instance IsStdMethod HTTP.CONNECT where - toStdMethod = const HTTP.CONNECT -instance IsStdMethod HTTP.OPTIONS where - toStdMethod = const HTTP.OPTIONS -instance IsStdMethod HTTP.PATCH where - toStdMethod = const HTTP.PATCH diff --git a/src/WebGear/Trait/Path.hs b/src/WebGear/Trait/Path.hs deleted file mode 100644 --- a/src/WebGear/Trait/Path.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | --- Copyright : (c) Raghu Kaippully, 2020 --- License : MPL-2.0 --- Maintainer : rkaippully@gmail.com --- --- Traits related to the route path of a request. -module WebGear.Trait.Path - ( Path - , PathVar - , PathVarFail (..) - ) where - -import Data.Kind (Type) -import Data.List (stripPrefix) -import Data.List.NonEmpty (toList) -import Data.Proxy (Proxy (..)) -import Data.Text (Text, pack) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Web.HttpApiData (FromHttpApiData (..)) - -import WebGear.Trait (CheckResult (..), Trait (..)) -import WebGear.Types (Request, pathInfo, setPathInfo) -import WebGear.Util (splitOn) - - --- | A path component which is literally matched against the request --- but discarded after that. -data Path (s :: Symbol) - -instance (KnownSymbol s, Monad m) => Trait (Path s) Request m where - type Val (Path s) Request = () - - -- | The path that could not be matched - type Fail (Path s) Request = () - - check :: Request -> m (CheckResult (Path s) Request) - check r = pure $ - let expected = map pack $ toList $ splitOn '/' $ symbolVal $ Proxy @s - actual = pathInfo r - in - case stripPrefix expected actual of - Nothing -> CheckFail () - Just rest -> CheckSuccess (setPathInfo rest r) () - - --- | A path variable that is extracted and converted to a value of --- type @val@. The @tag@ is usually a type-level symbol (string) to --- uniquely identify this variable. -data PathVar tag (val :: Type) - --- | Failure to extract a 'PathVar' -data PathVarFail = PathVarNotFound | PathVarParseError Text - deriving (Eq, Show, Read) - -instance (FromHttpApiData val, Monad m) => Trait (PathVar tag val) Request m where - type Val (PathVar tag val) Request = val - type Fail (PathVar tag val) Request = PathVarFail - - check :: Request -> m (CheckResult (PathVar tag val) Request) - check r = pure $ - case pathInfo r of - [] -> CheckFail PathVarNotFound - (x:xs) -> - case parseUrlPiece @val x of - Left e -> CheckFail $ PathVarParseError e - Right h -> CheckSuccess (setPathInfo xs r) h diff --git a/src/WebGear/Types.hs b/src/WebGear/Types.hs --- a/src/WebGear/Types.hs +++ b/src/WebGear/Types.hs @@ -4,87 +4,352 @@ -- Maintainer : rkaippully@gmail.com -- -- Common types and functions used throughout WebGear. +-- module WebGear.Types ( -- * WebGear Request - -- | WebGear requests are WAI requests. This module reexports a number - -- of useful functions that operate on requests from "Network.Wai" - -- module. Request , remoteHost , httpVersion , isSecure , requestMethod , pathInfo - , setPathInfo , queryString - , requestHeaders , requestHeader + , requestHeaders , requestBodyLength , getRequestBodyChunk -- * WebGear Response , Response (..) + , responseHeader + , setResponseHeader , waiResponse - , addResponseHeader + -- * Creating responses + , respond + , continue100 + , switchingProtocols101 + , ok200 + , created201 + , accepted202 + , nonAuthoritative203 + , noContent204 + , resetContent205 + , partialContent206 + , multipleChoices300 + , movedPermanently301 + , found302 + , seeOther303 + , notModified304 + , temporaryRedirect307 + , permanentRedirect308 + , badRequest400 + , unauthorized401 + , paymentRequired402 + , forbidden403 + , notFound404 + , methodNotAllowed405 + , notAcceptable406 + , proxyAuthenticationRequired407 + , requestTimeout408 + , conflict409 + , gone410 + , lengthRequired411 + , preconditionFailed412 + , requestEntityTooLarge413 + , requestURITooLong414 + , unsupportedMediaType415 + , requestedRangeNotSatisfiable416 + , expectationFailed417 + , imATeapot418 + , unprocessableEntity422 + , preconditionRequired428 + , tooManyRequests429 + , requestHeaderFieldsTooLarge431 + , internalServerError500 + , notImplemented501 + , badGateway502 + , serviceUnavailable503 + , gatewayTimeout504 + , httpVersionNotSupported505 + , networkAuthenticationRequired511 + + , Handler' , Handler + , Middleware' , Middleware + , RequestMiddleware' , RequestMiddleware + , ResponseMiddleware' , ResponseMiddleware + + , Router (..) + , MonadRouter (..) + , PathInfo (..) + , RouteError (..) + , transform + , runRoute + , toApplication ) where -import Control.Arrow (Kleisli) +import Control.Applicative (Alternative) +import Control.Arrow (Kleisli (..)) +import Control.Monad (MonadPlus) +import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State.Strict (MonadState, StateT, evalStateT) import Data.ByteString (ByteString) +import Data.ByteString.Conversion.To (ToByteString, toByteString) import Data.List (find) import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup (..), stimesIdempotent) +import Data.String (fromString) import Data.Text (Text) -import Network.HTTP.Types (Header, HeaderName, Status) +import Data.Version (showVersion) +import GHC.Exts (fromList) import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString, remoteHost, requestBodyLength, requestHeaders, requestMethod) -import WebGear.Trait (Linked) +import Paths_webgear_server (version) +import WebGear.Trait (Linked, link) import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM +import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai -- | Get the value of a request header -requestHeader :: HeaderName -> Request -> Maybe ByteString +requestHeader :: HTTP.HeaderName -> Request -> Maybe ByteString requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r) --- | Get request with an updated URL path info. -setPathInfo :: [Text] -> Request -> Request -setPathInfo p r = r { pathInfo = p } - --- | A response sent from the server to the client. +-- | An HTTP response sent from the server to the client. -- -- The response contains a status, optional headers and an optional -- body of type @a@. data Response a = Response - { respStatus :: Status -- ^ Response status code - , respHeaders :: HM.HashMap HeaderName ByteString -- ^ Response headers - , respBody :: Maybe a -- ^ Optional response body + { responseStatus :: HTTP.Status -- ^ Response status code + , responseHeaders :: HM.HashMap HTTP.HeaderName ByteString -- ^ Response headers + , responseBody :: Maybe a -- ^ Optional response body } + deriving stock (Eq, Ord, Show, Functor) +-- | Looks up a response header +responseHeader :: HTTP.HeaderName -> Response a -> Maybe ByteString +responseHeader h = HM.lookup h . responseHeaders + +-- | Set a response header value +setResponseHeader :: HTTP.HeaderName -> ByteString -> Response a -> Response a +setResponseHeader name val r = r { responseHeaders = HM.insert name val (responseHeaders r) } + -- | Convert a WebGear response to a WAI Response. waiResponse :: Response LBS.ByteString -> Wai.Response -waiResponse Response{..} = Wai.responseLBS respStatus (HM.toList respHeaders) (fromMaybe "" respBody) +waiResponse Response{..} = Wai.responseLBS + responseStatus + (HM.toList responseHeaders) + (fromMaybe "" responseBody) --- | Create or update a response header. -addResponseHeader :: Header -> Response a -> Response a -addResponseHeader (name, val) resp = resp { respHeaders = HM.insertWith f name val (respHeaders resp) } - where - f = flip const +-- | Create a response with a given status and body +respond :: HTTP.Status -> Maybe a -> Response a +respond s = Response s mempty + +-- | Continue 100 response +continue100 :: Response a +continue100 = respond HTTP.continue100 Nothing + +-- | Switching Protocols 101 response +switchingProtocols101 :: Response a +switchingProtocols101 = respond HTTP.switchingProtocols101 Nothing + +-- | OK 200 response +ok200 :: a -> Response a +ok200 = respond HTTP.ok200 . Just + +-- | Created 201 response +created201 :: a -> Response a +created201 = respond HTTP.created201 . Just + +-- | Accepted 202 response +accepted202 :: a -> Response a +accepted202 = respond HTTP.accepted202 . Just + +-- | Non-Authoritative 203 response +nonAuthoritative203 :: a -> Response a +nonAuthoritative203 = respond HTTP.nonAuthoritative203 . Just + +-- | No Content 204 response +noContent204 :: Response a +noContent204 = respond HTTP.noContent204 Nothing + +-- | Reset Content 205 response +resetContent205 :: Response a +resetContent205 = respond HTTP.resetContent205 Nothing + +-- | Partial Content 206 response +partialContent206 :: a -> Response a +partialContent206 = respond HTTP.partialContent206 . Just + +-- | Multiple Choices 300 response +multipleChoices300 :: a -> Response a +multipleChoices300 = respond HTTP.multipleChoices300 . Just + +-- | Moved Permanently 301 response +movedPermanently301 :: a -> Response a +movedPermanently301 = respond HTTP.movedPermanently301 . Just + +-- | Found 302 response +found302 :: a -> Response a +found302 = respond HTTP.found302 . Just + +-- | See Other 303 response +seeOther303 :: a -> Response a +seeOther303 = respond HTTP.seeOther303 . Just + +-- | Not Modified 304 response +notModified304 :: Response a +notModified304 = respond HTTP.notModified304 Nothing + +-- | Temporary Redirect 307 response +temporaryRedirect307 :: a -> Response a +temporaryRedirect307 = respond HTTP.temporaryRedirect307 . Just + +-- | Permanent Redirect 308 response +permanentRedirect308 :: a -> Response a +permanentRedirect308 = respond HTTP.permanentRedirect308 . Just + +-- | Bad Request 400 response +badRequest400 :: a -> Response a +badRequest400 = respond HTTP.badRequest400 . Just + +-- | Unauthorized 401 response +unauthorized401 :: a -> Response a +unauthorized401 = respond HTTP.unauthorized401 . Just + +-- | Payment Required 402 response +paymentRequired402 :: a -> Response a +paymentRequired402 = respond HTTP.paymentRequired402 . Just + +-- | Forbidden 403 response +forbidden403 :: a -> Response a +forbidden403 = respond HTTP.forbidden403 . Just + +-- | Not Found 404 response +notFound404 :: Response a +notFound404 = respond HTTP.notFound404 Nothing + +-- | Method Not Allowed 405 response +methodNotAllowed405 :: a -> Response a +methodNotAllowed405 = respond HTTP.methodNotAllowed405 . Just + +-- | Not Acceptable 406 response +notAcceptable406 :: a -> Response a +notAcceptable406 = respond HTTP.notAcceptable406 . Just + +-- | Proxy Authentication Required 407 response +proxyAuthenticationRequired407 :: a -> Response a +proxyAuthenticationRequired407 = respond HTTP.proxyAuthenticationRequired407 . Just + +-- | Request Timeout 408 response +requestTimeout408 :: a -> Response a +requestTimeout408 = respond HTTP.requestTimeout408 . Just + +-- | Conflict 409 response +conflict409 :: a -> Response a +conflict409 = respond HTTP.conflict409 . Just + +-- | Gone 410 response +gone410 :: a -> Response a +gone410 = respond HTTP.gone410 . Just + +-- | Length Required 411 response +lengthRequired411 :: a -> Response a +lengthRequired411 = respond HTTP.lengthRequired411 . Just + +-- | Precondition Failed 412 response +preconditionFailed412 :: a -> Response a +preconditionFailed412 = respond HTTP.preconditionFailed412 . Just + +-- | Request Entity Too Large 413 response +requestEntityTooLarge413 :: a -> Response a +requestEntityTooLarge413 = respond HTTP.requestEntityTooLarge413 . Just + +-- | Request URI Too Long 414 response +requestURITooLong414 :: a -> Response a +requestURITooLong414 = respond HTTP.requestURITooLong414 . Just + +-- | Unsupported Media Type 415 response +unsupportedMediaType415 :: a -> Response a +unsupportedMediaType415 = respond HTTP.unsupportedMediaType415 . Just + +-- | Requested Range Not Satisfiable 416 response +requestedRangeNotSatisfiable416 :: a -> Response a +requestedRangeNotSatisfiable416 = respond HTTP.requestedRangeNotSatisfiable416 . Just + +-- | Expectation Failed 417 response +expectationFailed417 :: a -> Response a +expectationFailed417 = respond HTTP.expectationFailed417 . Just + +-- | I'm A Teapot 418 response +imATeapot418 :: a -> Response a +imATeapot418 = respond HTTP.imATeapot418 . Just + +-- | Unprocessable Entity 422 response +unprocessableEntity422 :: a -> Response a +unprocessableEntity422 = respond HTTP.unprocessableEntity422 . Just + +-- | Precondition Required 428 response +preconditionRequired428 :: a -> Response a +preconditionRequired428 = respond HTTP.preconditionRequired428 . Just + +-- | Too Many Requests 429 response +tooManyRequests429 :: a -> Response a +tooManyRequests429 = respond HTTP.tooManyRequests429 . Just + +-- | Request Header Fields Too Large 431 response +requestHeaderFieldsTooLarge431 :: a -> Response a +requestHeaderFieldsTooLarge431 = respond HTTP.requestHeaderFieldsTooLarge431 . Just + +-- | Internal Server Error 500 response +internalServerError500 :: a -> Response a +internalServerError500 = respond HTTP.internalServerError500 . Just + +-- | Not Implemented 501 response +notImplemented501 :: a -> Response a +notImplemented501 = respond HTTP.notImplemented501 . Just + +-- | Bad Gateway 502 response +badGateway502 :: a -> Response a +badGateway502 = respond HTTP.badGateway502 . Just + +-- | Service Unavailable 503 response +serviceUnavailable503 :: a -> Response a +serviceUnavailable503 = respond HTTP.serviceUnavailable503 . Just + +-- | Gateway Timeout 504 response +gatewayTimeout504 :: a -> Response a +gatewayTimeout504 = respond HTTP.gatewayTimeout504 . Just + +-- | HTTP Version Not Supported 505 response +httpVersionNotSupported505 :: a -> Response a +httpVersionNotSupported505 = respond HTTP.httpVersionNotSupported505 . Just + +-- | Network Authentication Required 511 response +networkAuthenticationRequired511 :: a -> Response a +networkAuthenticationRequired511 = respond HTTP.networkAuthenticationRequired511 . Just + + + -- | A handler is a function from a request to response in a monadic -- context. Both the request and the response can have linked traits. -- -- The type level list @req@ contains all the traits expected to be --- present in the request. The handler will produce a response that --- satisfies all the traits in the type level list @res@. -type Handler m req res a = Kleisli m (Linked req Request) (Linked res (Response a)) +-- present in the request. +type Handler' m req a = Kleisli m (Linked req Request) (Response a) +-- | A handler that runs on the 'Router' monad. +type Handler req a = Handler' Router req a + -- | A middleware takes a handler as input and produces another -- handler that usually adds some functionality. -- @@ -92,16 +357,114 @@ -- handling such as: -- -- * Change the request traits before invoking the handler. --- * Change the response traits before passing it back to its caller. --- * Use the linked value of any of the request or response traits. +-- * Use the linked value of any of the request traits. -- * Change the response body. -- -type Middleware m req req' res' res a' a = Handler m req' res' a' -> Handler m req res a +type Middleware' m req req' a' a = Handler' m req' a' -> Handler' m req a --- | A middleware that manipulates only the request traits and leaves --- the response unchanged. -type RequestMiddleware m req req' res a = Middleware m req req' res res a a +-- | A middleware that runs on the 'Router' monad. +type Middleware req req' a' a = Middleware' Router req req' a' a --- | A middleware that manipulates only the response traits and leaves --- the request unchanged. -type ResponseMiddleware m req res' res a = Middleware m req req res' res a a +-- | A middleware that manipulates only the request traits and passes +-- the response through. +type RequestMiddleware' m req req' a = Middleware' m req req' a a + +-- | A request middleware that runs on the 'Router' monad. +type RequestMiddleware req req' a = RequestMiddleware' Router req req' a + +-- | A middleware that manipulates only the response and passes the +-- request through. +type ResponseMiddleware' m req a' a = Middleware' m req req a' a + +-- | A response middleware that runs on the 'Router' monad. +type ResponseMiddleware req a' a = ResponseMiddleware' Router req a' a + +-- | A natural transformation of handler monads. +-- +-- This is useful if you want to run a handler in a monad other than +-- 'Router'. +-- +transform :: (forall x. m x -> n x) -> Handler' m req a -> Handler' n req a +transform f (Kleisli mf) = Kleisli $ f . mf + +-- | The path components to be matched by routing machinery +newtype PathInfo = PathInfo [Text] + +-- | Responses that cause routes to abort execution +data RouteError = RouteMismatch + -- ^ A route did not match and the next one can be + -- tried + | ErrorResponse (Response LBS.ByteString) + -- ^ A route matched but returned a short circuiting + -- error response + deriving (Eq, Ord, Show) + +instance Semigroup RouteError where + RouteMismatch <> e = e + e <> _ = e + + stimes :: Integral b => b -> RouteError -> RouteError + stimes = stimesIdempotent + +instance Monoid RouteError where + mempty = RouteMismatch + +-- | The monad for routing. +newtype Router a = Router + { unRouter :: StateT PathInfo (ExceptT RouteError IO) a } + deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus + , MonadError RouteError + , MonadState PathInfo + , MonadIO + ) + +-- | HTTP request routing with short circuiting behavior. +class (MonadState PathInfo m, Alternative m, MonadPlus m) => MonadRouter m where + -- | Mark the current route as rejected, alternatives can be tried + rejectRoute :: m a + + -- | Short-circuit the current handler and return a response + errorResponse :: Response LBS.ByteString -> m a + + -- | Handle an error response + catchErrorResponse :: m a -> (Response LBS.ByteString -> m a) -> m a + +instance MonadRouter Router where + rejectRoute :: Router a + rejectRoute = throwError RouteMismatch + + errorResponse :: Response LBS.ByteString -> Router a + errorResponse = throwError . ErrorResponse + + catchErrorResponse :: Router a -> (Response LBS.ByteString -> Router a) -> Router a + catchErrorResponse action handle = action `catchError` f + where + f RouteMismatch = rejectRoute + f (ErrorResponse res) = handle res + + +-- | Convert a routable handler into a plain function from request to response. +runRoute :: ToByteString a => Handler '[] a -> (Wai.Request -> IO Wai.Response) +runRoute route req = waiResponse . addServerHeader . either routeErrorToResponse id <$> runRouter + where + runRouter :: IO (Either RouteError (Response LBS.ByteString)) + runRouter = fmap (fmap (fmap toByteString)) + $ runExceptT + $ flip evalStateT (PathInfo $ pathInfo req) + $ unRouter + $ runKleisli route + $ link req + + routeErrorToResponse :: RouteError -> Response LBS.ByteString + routeErrorToResponse RouteMismatch = notFound404 + routeErrorToResponse (ErrorResponse r) = r + + addServerHeader :: Response LBS.ByteString -> Response LBS.ByteString + addServerHeader r = r { responseHeaders = responseHeaders r <> fromList [serverHeader] } + + serverHeader :: HTTP.Header + serverHeader = (HTTP.hServer, fromString $ "WebGear/" ++ showVersion version) + +-- | Convert a routable handler into a Wai application +toApplication :: ToByteString a => Handler '[] a -> Wai.Application +toApplication route request next = runRoute route request >>= next diff --git a/src/WebGear/Util.hs b/src/WebGear/Util.hs --- a/src/WebGear/Util.hs +++ b/src/WebGear/Util.hs @@ -7,6 +7,7 @@ module WebGear.Util ( takeWhileM , splitOn + , maybeToRight ) where import Data.List.NonEmpty (NonEmpty (..), toList) @@ -25,3 +26,7 @@ where f x acc | x == sep = [] :| toList acc f x (y :| ys) = (x:y) :| ys + +maybeToRight :: a -> Maybe b -> Either a b +maybeToRight _ (Just x) = Right x +maybeToRight y Nothing = Left y diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -9,15 +9,19 @@ import Test.Tasty (TestTree, testGroup) +import qualified Properties.Trait.Auth.Basic as Basic import qualified Properties.Trait.Body as Body import qualified Properties.Trait.Header as Header import qualified Properties.Trait.Method as Method +import qualified Properties.Trait.Params as Params import qualified Properties.Trait.Path as Path propertyTests :: TestTree -propertyTests = testGroup "Property Tests" [ Body.tests - , Header.tests - , Method.tests +propertyTests = testGroup "Property Tests" [ Method.tests , Path.tests + , Header.tests + , Params.tests + , Body.tests + , Basic.tests ] diff --git a/test/Properties/Trait/Auth/Basic.hs b/test/Properties/Trait/Auth/Basic.hs new file mode 100644 --- /dev/null +++ b/test/Properties/Trait/Auth/Basic.hs @@ -0,0 +1,43 @@ +module Properties.Trait.Auth.Basic + ( tests + ) where + +import Data.ByteString.Base64 (encode) +import Data.ByteString.Char8 (elem) +import Data.Functor.Identity (runIdentity) +import Network.Wai (defaultRequest) +import Prelude hiding (elem) +import Test.QuickCheck (Discard (..), Property, allProperties, counterexample, property, (.&&.), + (===)) +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperties) + +import WebGear.Middlewares.Auth.Basic +import WebGear.Trait +import WebGear.Types + + +prop_basicAuth :: Property +prop_basicAuth = property f + where + f (username, password) + | ':' `elem` username = property Discard + | otherwise = + let + hval = "Basic " <> encode (username <> ":" <> password) + req = defaultRequest { requestHeaders = [("Authorization", hval)] } + in + case runIdentity (toAttribute @BasicAuth req) of + Found creds -> + credentialsUsername creds === Username username + .&&. credentialsPassword creds === Password password + NotFound e -> + counterexample ("Unexpected failure: " <> show e) (property False) + + +-- Hack for TH splicing +return [] + +tests :: TestTree +tests = testProperties "Trait.Auth.Basic" $allProperties diff --git a/test/Properties/Trait/Body.hs b/test/Properties/Trait/Body.hs --- a/test/Properties/Trait/Body.hs +++ b/test/Properties/Trait/Body.hs @@ -7,15 +7,16 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.IORef (newIORef, readIORef, writeIORef) import Data.String (fromString) -import Network.Wai (Request, defaultRequest, requestBody) +import Network.Wai (defaultRequest, requestBody) import Test.QuickCheck (Property, allProperties, counterexample, property) import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic (assert, monadicIO, monitor) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) +import WebGear.Middlewares.Body import WebGear.Trait -import WebGear.Trait.Body +import WebGear.Types bodyToRequest :: (MonadIO m, Show a) => a -> m Request @@ -27,23 +28,23 @@ prop_emptyRequestBodyFails :: Property prop_emptyRequestBodyFails = monadicIO $ do req <- bodyToRequest ("" :: String) - check @(JSONRequestBody Int) req >>= \case - CheckSuccess _ _ -> monitor (counterexample "Unexpected success") >> assert False - CheckFail _ -> assert True + toAttribute @(JSONRequestBody Int) req >>= \case + Found _ -> monitor (counterexample "Unexpected success") >> assert False + NotFound _ -> assert True prop_validBodyParses :: Property prop_validBodyParses = property $ \n -> monadicIO $ do req <- bodyToRequest (n :: Integer) - check @(JSONRequestBody Integer) req >>= \case - CheckSuccess _ n' -> assert (n == n') - CheckFail _ -> assert False + toAttribute @(JSONRequestBody Integer) req >>= \case + Found n' -> assert (n == n') + NotFound _ -> assert False prop_invalidBodyFails :: Property prop_invalidBodyFails = property $ \n -> monadicIO $ do req <- bodyToRequest (n :: Integer) - check @(JSONRequestBody String) req >>= \case - CheckSuccess _ _ -> assert False - CheckFail _ -> assert True + toAttribute @(JSONRequestBody String) req >>= \case + Found _ -> assert False + NotFound _ -> assert True -- Hack for TH splicing diff --git a/test/Properties/Trait/Header.hs b/test/Properties/Trait/Header.hs --- a/test/Properties/Trait/Header.hs +++ b/test/Properties/Trait/Header.hs @@ -5,14 +5,15 @@ import Data.Functor.Identity (runIdentity) import Data.String (fromString) import Data.Text.Encoding (encodeUtf8) -import Network.Wai (defaultRequest, requestHeaders) +import Network.Wai (defaultRequest) import Test.QuickCheck (Property, allProperties, counterexample, property, (.&&.), (=/=), (===)) import Test.QuickCheck.Instances () import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) +import WebGear.Middlewares.Header import WebGear.Trait -import WebGear.Trait.Header +import WebGear.Types prop_headerParseError :: Property @@ -21,31 +22,33 @@ hval' = "test-" <> hval req = defaultRequest { requestHeaders = [("foo", encodeUtf8 hval')] } in - case runIdentity (check @(Header "foo" Int) req) of - CheckFail e -> - e === HeaderParseError ("could not parse: `" <> hval' <> "' (input does not start with a digit)") - CheckSuccess _ v -> + case runIdentity (toAttribute @(Header "foo" Int) req) of + Found v -> counterexample ("Unexpected result: " <> show v) (property False) + NotFound e -> + e === Right (HeaderParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") prop_headerParseSuccess :: Property prop_headerParseSuccess = property $ \(n :: Int) -> let req = defaultRequest { requestHeaders = [("foo", fromString $ show n)] } in - case runIdentity (check @(Header "foo" Int) req) of - CheckFail e -> + case runIdentity (toAttribute @(Header "foo" Int) req) of + Found n' -> n === n' + NotFound e -> counterexample ("Unexpected result: " <> show e) (property False) - CheckSuccess _ n' -> n === n' prop_headerMatch :: Property prop_headerMatch = property $ \v -> let req = defaultRequest { requestHeaders = [("foo", v)] } in - case runIdentity (check @(HeaderMatch "foo" "bar") req) of - CheckFail e -> - expectedHeader e === "bar" .&&. actualHeader e =/= Nothing .&&. actualHeader e =/= Just "bar" - CheckSuccess _ v' -> v === "bar" .&&. v === v' + case runIdentity (toAttribute @(HeaderMatch "foo" "bar") req) of + Found _ -> v === "bar" + NotFound Nothing -> + counterexample "Unexpected result: Nothing" (property False) + NotFound (Just e) -> + expectedHeader e === "bar" .&&. actualHeader e =/= "bar" -- Hack for TH splicing diff --git a/test/Properties/Trait/Method.hs b/test/Properties/Trait/Method.hs --- a/test/Properties/Trait/Method.hs +++ b/test/Properties/Trait/Method.hs @@ -4,14 +4,15 @@ import Data.Functor.Identity (runIdentity) import Network.HTTP.Types (StdMethod (..), methodGet, renderStdMethod) -import Network.Wai (defaultRequest, requestMethod) +import Network.Wai (defaultRequest) import Test.QuickCheck (Arbitrary (arbitrary), Property, allProperties, elements, property, (.&&.), (=/=), (===)) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) +import WebGear.Middlewares.Method import WebGear.Trait -import WebGear.Trait.Method +import WebGear.Types newtype MethodWrapper = MethodWrapper StdMethod @@ -25,9 +26,9 @@ let req = defaultRequest { requestMethod = renderStdMethod v } in - case runIdentity (check @(Method GET) req) of - CheckSuccess _ v' -> v === GET .&&. v' === methodGet - CheckFail e -> + case runIdentity (toAttribute @(Method GET) req) of + Found _ -> v === GET + NotFound e -> expectedMethod e === methodGet .&&. actualMethod e =/= methodGet diff --git a/test/Properties/Trait/Params.hs b/test/Properties/Trait/Params.hs new file mode 100644 --- /dev/null +++ b/test/Properties/Trait/Params.hs @@ -0,0 +1,46 @@ +module Properties.Trait.Params + ( tests + ) where + +import Data.Functor.Identity (runIdentity) +import Data.String (fromString) +import Data.Text.Encoding (encodeUtf8) +import Network.Wai (defaultRequest) +import Test.QuickCheck (Property, allProperties, counterexample, property, (===)) +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperties) + +import WebGear.Middlewares.Params +import WebGear.Trait +import WebGear.Types + + +prop_paramParseError :: Property +prop_paramParseError = property $ \hval -> + let + hval' = "test-" <> hval + req = defaultRequest { queryString = [("foo", Just $ encodeUtf8 hval')] } + in + case runIdentity (toAttribute @(QueryParam "foo" Int) req) of + Found v -> + counterexample ("Unexpected result: " <> show v) (property False) + NotFound e -> + e === Right (ParamParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") + +prop_paramParseSuccess :: Property +prop_paramParseSuccess = property $ \(n :: Int) -> + let + req = defaultRequest { queryString = [("foo", Just $ fromString $ show n)] } + in + case runIdentity (toAttribute @(QueryParam "foo" Int) req) of + Found n' -> n === n' + NotFound e -> + counterexample ("Unexpected result: " <> show e) (property False) + + +-- Hack for TH splicing +return [] + +tests :: TestTree +tests = testProperties "Trait.Params" $allProperties diff --git a/test/Properties/Trait/Path.hs b/test/Properties/Trait/Path.hs --- a/test/Properties/Trait/Path.hs +++ b/test/Properties/Trait/Path.hs @@ -2,16 +2,17 @@ ( tests ) where -import Data.Functor.Identity (runIdentity) +import Control.Monad.State.Strict (evalState) import Data.String (fromString) -import Network.Wai (defaultRequest, pathInfo) -import Test.QuickCheck (Property, allProperties, property, (.&&.), (=/=), (===)) +import Network.Wai (defaultRequest) +import Test.QuickCheck (Property, allProperties, property, (=/=), (===)) import Test.QuickCheck.Instances () import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperties) +import WebGear.Middlewares.Path import WebGear.Trait -import WebGear.Trait.Path +import WebGear.Types prop_pathMatch :: Property @@ -20,9 +21,9 @@ rest = ["foo", "bar"] req = defaultRequest { pathInfo = h:rest } in - case runIdentity (check @(Path "a") req) of - CheckSuccess req' _ -> h === "a" .&&. pathInfo req' === rest - CheckFail _ -> h =/= "a" + case evalState (toAttribute @(Path "a") req) (PathInfo $ h:rest) of + Found _ -> h === "a" + NotFound _ -> h =/= "a" prop_pathVarMatch :: Property prop_pathVarMatch = property $ \(n :: Int) -> @@ -30,9 +31,9 @@ rest = ["foo", "bar"] req = defaultRequest { pathInfo = fromString (show n):rest } in - case runIdentity (check @(PathVar "tag" Int) req) of - CheckSuccess req' n' -> n' === n .&&. pathInfo req' === rest - CheckFail _ -> property False + case evalState (toAttribute @(PathVar "tag" Int) req) (PathInfo $ pathInfo req) of + Found n' -> n' === n + NotFound _ -> property False prop_pathVarParseError :: Property prop_pathVarParseError = property $ \(p, ps) -> @@ -40,9 +41,9 @@ p' = "test-" <> p req = defaultRequest { pathInfo = p':ps } in - case runIdentity (check @(PathVar "tag" Int) req) of - CheckSuccess _ _ -> property False - CheckFail e -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)") + case evalState (toAttribute @(PathVar "tag" Int) req) (PathInfo $ pathInfo req) of + Found _ -> property False + NotFound e -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)") -- Hack for TH splicing diff --git a/test/Unit/Trait/Header.hs b/test/Unit/Trait/Header.hs --- a/test/Unit/Trait/Header.hs +++ b/test/Unit/Trait/Header.hs @@ -7,36 +7,35 @@ ( tests ) where -import Network.Wai (defaultRequest, requestHeaders) +import Network.Wai (defaultRequest) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import WebGear.Middlewares.Header import WebGear.Trait -import WebGear.Trait.Header +import WebGear.Types testMissingHeaderFails :: TestTree testMissingHeaderFails = testCase "Missing header fails Header trait" $ do let req = defaultRequest { requestHeaders = [] } - check @(Header "foo" Int) req >>= \case - CheckSuccess _ _ -> assertFailure "unexpected success" - CheckFail e -> e @?= HeaderNotFound + toAttribute @(Header "foo" Int) req >>= \case + Found _ -> assertFailure "unexpected success" + NotFound e -> e @?= Left HeaderNotFound testHeaderMatchPositive :: TestTree testHeaderMatchPositive = testCase "Header match: positive" $ do let req = defaultRequest { requestHeaders = [("foo", "bar")] } - check @(HeaderMatch "foo" "bar") req >>= \case - CheckSuccess _ v -> v @?= "bar" - CheckFail e -> assertFailure $ "Unexpected result: " <> show e + toAttribute @(HeaderMatch "foo" "bar") req >>= \case + Found _ -> pure () + NotFound e -> assertFailure $ "Unexpected result: " <> show e testHeaderMatchMissingHeader :: TestTree testHeaderMatchMissingHeader = testCase "Header match: missing header" $ do let req = defaultRequest { requestHeaders = [] } - check @(HeaderMatch "foo" "bar") req >>= \case - CheckSuccess _ _ -> assertFailure "unexpected success" - CheckFail e -> e @?= HeaderMismatch { expectedHeader = "bar" - , actualHeader = Nothing - } + toAttribute @(HeaderMatch "foo" "bar") req >>= \case + Found _ -> assertFailure "unexpected success" + NotFound e -> e @?= Nothing tests :: TestTree tests = testGroup "Trait.Header" [ testMissingHeaderFails diff --git a/test/Unit/Trait/Path.hs b/test/Unit/Trait/Path.hs --- a/test/Unit/Trait/Path.hs +++ b/test/Unit/Trait/Path.hs @@ -7,20 +7,22 @@ ( tests ) where -import Network.Wai (defaultRequest, pathInfo) +import Control.Monad.State (evalState) +import Network.Wai (defaultRequest) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import WebGear.Middlewares.Path import WebGear.Trait -import WebGear.Trait.Path +import WebGear.Types testMissingPathVar :: TestTree testMissingPathVar = testCase "PathVar match: missing variable" $ do let req = defaultRequest { pathInfo = [] } - check @(PathVar "tag" Int) req >>= \case - CheckSuccess _ _ -> assertFailure "unexpected success" - CheckFail e -> e @?= PathVarNotFound + case evalState (toAttribute @(PathVar "tag" Int) req) (PathInfo []) of + Found _ -> assertFailure "unexpected success" + NotFound e -> e @?= PathVarNotFound tests :: TestTree tests = testGroup "Trait.Path" [ testMissingPathVar ] diff --git a/webgear-server.cabal b/webgear-server.cabal --- a/webgear-server.cabal +++ b/webgear-server.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: webgear-server -version: 0.1.0 +version: 0.2.0 synopsis: Composable, type-safe library to build HTTP API servers description: WebGear is a library to for building composable, type-safe HTTP API servers. @@ -28,78 +28,61 @@ common webgear-common default-language: Haskell2010 - default-extensions: ApplicativeDo - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveFoldable + default-extensions: DataKinds DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable DerivingStrategies - DerivingVia - EmptyCase - ExistentialQuantification FlexibleContexts FlexibleInstances - FunctionalDependencies - GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses - MultiWayIf - NamedFieldPuns OverloadedStrings - PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections + TemplateHaskellQuotes TypeApplications TypeFamilies - TypeFamilyDependencies TypeOperators - build-depends: base >=4.13.0.0 && <5 - , template-haskell >=2.15.0.0 && <3 + build-depends: base >=4.12.0.0 && <5 + , template-haskell >=2.14.0.0 && <3 , mtl ==2.2.* , unordered-containers ==0.2.* , wai ==3.2.* , bytestring ==0.10.* , text ==1.2.* + , case-insensitive ==1.2.* + , base64-bytestring >=1.0.0.3 && <1.3 + , bytestring-conversion ==0.3.* , http-types ==0.12.* , http-api-data ==0.4.* - , aeson ==1.4.* - , tagged ==0.8.* - ghc-options: -fwrite-ide-info - -hiedir=.hie - -Wall + , aeson >=1.4 && <1.6 + , network >=2.8 && <3.2 + ghc-options: -Wall -Wno-unticked-promoted-constructors -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + if impl(ghc >= 8.8.1) + ghc-options: -fwrite-ide-info + -hiedir=.hie + library import: webgear-common exposed-modules: WebGear + , WebGear.Modifiers , WebGear.Trait - , WebGear.Trait.Method - , WebGear.Trait.Header - , WebGear.Trait.Path - , WebGear.Trait.Body , WebGear.Types - , WebGear.Route , WebGear.Middlewares + , WebGear.Middlewares.Auth.Basic , WebGear.Middlewares.Body , WebGear.Middlewares.Header , WebGear.Middlewares.Method + , WebGear.Middlewares.Params , WebGear.Middlewares.Path other-modules: Paths_webgear_server , WebGear.Util @@ -116,15 +99,18 @@ , Properties , Properties.Trait.Body , Properties.Trait.Header + , Properties.Trait.Params , Properties.Trait.Method , Properties.Trait.Path + , Properties.Trait.Auth.Basic hs-source-dirs: test + default-extensions: TemplateHaskell ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: tasty ==1.2.* + build-depends: tasty >=1.2 && <1.4 , tasty-quickcheck ==0.10.* , tasty-hunit ==0.10.* - , QuickCheck ==2.13.* + , QuickCheck >=2.13 && <2.15 , quickcheck-instances ==0.3.* , webgear-server