webgear-server 0.1.0 → 0.2.0

raw patch · 28 files changed

+1731/−729 lines, 28 filesdep +base64-bytestringdep +bytestring-conversiondep +case-insensitivedep −taggeddep ~QuickCheckdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, bytestring-conversion, case-insensitive, network

Dependencies removed: tagged

Dependency ranges changed: QuickCheck, aeson, base, tasty, template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−3
• src/WebGear.hs +117/−70
• src/WebGear/Middlewares.hs +5/−29
• src/WebGear/Middlewares/Auth/Basic.hs +120/−0
• src/WebGear/Middlewares/Body.hs +33/−26
• src/WebGear/Middlewares/Header.hs +334/−25
• src/WebGear/Middlewares/Method.hs +61/−8
• src/WebGear/Middlewares/Params.hs +186/−0
• src/WebGear/Middlewares/Path.hs +160/−38
• src/WebGear/Modifiers.hs +18/−0
• src/WebGear/Route.hs +0/−81
• src/WebGear/Trait.hs +93/−74
• src/WebGear/Trait/Body.hs +0/−34
• src/WebGear/Trait/Header.hs +0/−71
• src/WebGear/Trait/Method.hs +0/−68
• src/WebGear/Trait/Path.hs +0/−66
• src/WebGear/Types.hs +399/−36
• src/WebGear/Util.hs +5/−0
• test/Properties.hs +7/−3
• test/Properties/Trait/Auth/Basic.hs +43/−0
• test/Properties/Trait/Body.hs +12/−11
• test/Properties/Trait/Header.hs +16/−13
• test/Properties/Trait/Method.hs +6/−5
• test/Properties/Trait/Params.hs +46/−0
• test/Properties/Trait/Path.hs +14/−13
• test/Unit/Trait/Header.hs +12/−13
• test/Unit/Trait/Path.hs +7/−5
• webgear-server.cabal +23/−37

@@ -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

@@ -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. --

@@ -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 ""

@@ -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"

@@ -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

@@ -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)

@@ -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)

@@ -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)

@@ -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 ".")

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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                                            ]

@@ -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

@@ -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

@@ -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

@@ -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  

@@ -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

@@ -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

@@ -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

@@ -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 ]

@@ -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