packages feed

webgear-server 0.2.1 → 1.0.0

raw patch · 39 files changed

+1062/−2396 lines, 39 filesdep +arrowsdep +http-mediadep +josedep −case-insensitivedep −networkdep −template-haskelldep ~aesondep ~basedep ~bytestring

Dependencies added: arrows, http-media, jose, monad-time, webgear-core

Dependencies removed: case-insensitive, network, template-haskell

Dependency ranges changed: aeson, base, bytestring

Files

+ CHANGELOG.md view
@@ -0,0 +1,38 @@+# Changelog for webgear-server++## [Unreleased]++## [1.0.0] - 2022-01-08++### Changed+- New home at https://github.com/haskell-webgear/webgear+- New arrow based API++## [0.2.1] - 2021-01-11++### Changed+- Upgrade to latest version of LTS and deps++## [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++[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.0.0...HEAD+[1.0.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.0+[0.2.1]: https://github.com/haskell-webgear/webgear-server/compare/v0.2.0...v0.2.1+[0.2.0]: https://github.com/haskell-webgear/webgear-server/compare/v0.1.0...v0.2.0+[0.1.0]: https://github.com/haskell-webgear/webgear-server/releases/tag/v0.1.0
− ChangeLog.md 
@@ -1,31 +0,0 @@-# Changelog for webgear-server--## Unreleased changes--## [0.2.1] - 2021-01-11--### Changed-- Upgrade to latest version of LTS and deps--## [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--[Unreleased]: https://github.com/rkaippully/webgear/compare/v0.2.0...HEAD-[0.2.1]: https://github.com/rkaippully/webgear/compare/v0.2.0...v0.2.1-[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
README.md view
@@ -1,9 +1,6 @@ # WebGear - HTTP API server  [![Hackage](https://img.shields.io/hackage/v/webgear-server)](https://hackage.haskell.org/package/webgear-server)-[![Build Status](https://img.shields.io/github/workflow/status/rkaippully/webgear/Haskell%20CI/master)](https://github.com/rkaippully/webgear/actions?query=workflow%3A%22Haskell+CI%22+branch%3Amaster) -WebGear is a Haskell library for building composable, type-safe HTTP API servers. It focuses on good documentation and-usability.--See the documentation of WebGear module to get started.+WebGear is a Haskell library for building composable, type-safe HTTP APIs. This package helps to generate+[WAI](https://hackage.haskell.org/package/wai) applications based on WebGear API specifications.
− src/WebGear.hs 
@@ -1,290 +0,0 @@-{-# OPTIONS_GHC -Wno-unused-imports #-}-{-# OPTIONS_HADDOCK ignore-exports #-}--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ WebGear helps to build composable, type-safe HTTP API servers.------ The documentation below gives an overview of WebGear. Example--- programs built using WebGear are available at--- https://github.com/rkaippully/webgear/tree/master/webgear-examples.----module WebGear-  ( -- * Serving HTTP APIs-    -- $serving--    -- * Traits and Linking-    -- $traits--    -- * Handlers-    -- $handlers--    -- * Middlewares-    -- $middlewares--    -- * Routing-    -- $routing--    -- * 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.Arrow (Kleisli (..))-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.Trait-import WebGear.Types-------- $serving------ An HTTP API server handler can be thought of as a function that--- takes a request as input and produces a response as output in a--- monadic context.------ > 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--- parameters, or the request body. WebGear allows to access such--- information using traits.--------- $traits------ A trait is an attribute associated with a value. For example, a--- @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 '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 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:------   * '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.------   * '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--- that our handler is called only for GET requests. We can link a--- request value with this trait using:------ @--- 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 :: Linked req Request -> Router Response------ Here, @req@ is a type-level list of traits associated with the--- @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------ Handlers in WebGear are defined with a type very similar to the--- above.------ @--- 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--- type-level trait lists. However, the response is parameterized by--- 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--- 'get' function.--------- $middlewares------ A middleware is a higher-order function that takes a handler as--- 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) a -> 'Handler'' m req a--- method handler = 'Kleisli' $ 'probe' \@('Method' t) >=> 'either' ('const' 'rejectRoute') ('runKleisli' handler)--- @------ 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. For example:------ @--- putUser = 'method' \@PUT---           $ 'requestContentTypeHeader' \@"application/json"---           $ 'jsonRequestBody' \@User---           $ 'jsonResponseBody' \@User---           $ putUserHandler--- @--------- $routing------ A typical server will have many routes and we would like to pick--- one based on the URL path, HTTP method etc. We need a couple of--- things to achieve this.------ First, we need a way to indicate that a handler cannot handle a--- request, possibly because the path or method did not match with--- what was expected. This is achieved by the 'rejectRoute' function:------ @--- class (Alternative m, MonadPlus m) => 'MonadRouter' m where---   'rejectRoute' :: m a---   'errorResponse' :: 'Response' 'ByteString' -> m a---   'catchErrorResponse' :: m a -> ('Response' 'ByteString' -> m a) -> m a--- @------ 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, 'errorResponse' can be used to abort and return an--- error response.------ Second, we need a mechanism to try an alternate route when one--- route is rejected. Since 'MonadRouter' is an 'Alternative', we can--- use '<|>' to combine many routes. When a request arrives, a match--- will be attempted against each route sequentially and the first--- matching route handler will process the request. Here is an--- example:------ @--- 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 :: 'Has' IntUserId req => 'Handler' req 'ByteString'--- getUser = 'method' \@GET getUserHandler------ putUser :: 'Has' IntUserId req => 'Handler' req 'ByteString'--- putUser = 'method' \@PUT---           $ 'requestContentTypeHeader' \@"application/json"---           $ 'jsonRequestBody' \@User---           $ putUserHandler------ deleteUser :: 'Has' IntUserId req => 'Handler' req 'ByteString'--- deleteUser = 'method' \@DELETE deleteUserHandler--- @--------- $running------ Routable handlers can be converted to a Wai 'Wai.Application' using--- 'toApplication':------ @--- toApplication :: 'ToByteString' a => 'Handler' '[] a -> 'Wai.Application'--- @------ This Wai application can then be run as a Warp web server.------ @--- main :: IO ()--- 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.---
− src/WebGear/Middlewares.hs 
@@ -1,22 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Middlewares provided by WebGear.----module WebGear.Middlewares-  ( 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 WebGear.Middlewares.Auth.Basic-import WebGear.Middlewares.Body-import WebGear.Middlewares.Header-import WebGear.Middlewares.Method-import WebGear.Middlewares.Params-import WebGear.Middlewares.Path
− src/WebGear/Middlewares/Auth/Basic.hs 
@@ -1,120 +0,0 @@--- |--- 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"
− src/WebGear/Middlewares/Body.hs 
@@ -1,71 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Middlewares related to HTTP body.-module WebGear.Middlewares.Body-  ( JSONRequestBody-  , jsonRequestBody-  , jsonResponseBody-  ) where--import Control.Arrow (Kleisli (..))-import Control.Monad ((>=>))-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 (hContentType)--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.------ Usage for a type @t@ which has a 'FromJSON' instance:------ > jsonRequestBody @t handler------ 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 $-  probe @(JSONRequestBody t) >=> either (errorResponse . mkError) (runKleisli handler)-  where-    mkError :: Text -> Response ByteString-    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.------ This will also set the "Content-Type" header of the response to--- "application/json".------ Usage for a type @t@ which has a 'ToJSON' instance:------ > jsonResponseBody @t handler----jsonResponseBody :: (ToJSON t, Monad m) => ResponseMiddleware' m req t ByteString-jsonResponseBody handler = Kleisli $ \req -> do-  x <- runKleisli handler req-  pure $ setResponseHeader hContentType "application/json" $ encode <$> x
− src/WebGear/Middlewares/Header.hs 
@@ -1,356 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Middlewares related to HTTP headers.----module WebGear.Middlewares.Header-  ( -- * 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 (ByteString)-import Data.Kind (Type)-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 (HeaderName)-import Text.Printf (printf)-import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))--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.------ Example usage:------ > requestContentTypeHeader @"application/json" handler----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)
− src/WebGear/Middlewares/Method.hs 
@@ -1,85 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Middlewares related to HTTP methods.-module WebGear.Middlewares.Method-  ( Method-  , IsStdMethod (..)-  , MethodMismatch (..)-  , method-  ) where--import Control.Arrow (Kleisli (..))-import Control.Monad ((>=>))-import Data.Proxy (Proxy (..))--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.------ Typically this would be used with a type application such as:------ > method @GET handler------ 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 a. (IsStdMethod t, MonadRouter m)-       => RequestMiddleware' m req (Method t:req) a-method handler = Kleisli $ probe @(Method t) >=> either (const rejectRoute) (runKleisli handler)
− src/WebGear/Middlewares/Params.hs 
@@ -1,186 +0,0 @@--- |--- 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)
− src/WebGear/Middlewares/Path.hs 
@@ -1,237 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Middlewares related to route paths.-module WebGear.Middlewares.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 (..), 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 Prelude hiding (drop, filter, take)-import Web.HttpApiData (FromHttpApiData (..))--import WebGear.Middlewares.Method (method)-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--- forward slash character. The route will be rejected if there is no--- match.------ For example, the following code could be used to match the URL path--- \"a\/b\/c\" and then invoke @handler@:------ > path @"a/b/c" handler----path :: forall s ts m a. (KnownSymbol s, MonadRouter m)-     => RequestMiddleware' m ts (Path s:ts) a-path handler = Kleisli $-  probe @(Path s) >=> either (const rejectRoute) (runKleisli handler)---- | A middleware that captures a path variable from a single path--- component.------ The value captured is converted to a value of type @val@ via--- 'FromHttpApiData'. The route will be rejected if the value is not--- found or cannot be converted.------ For example, the following code could be used to read a path--- component as 'Int' tagged with the symbol \"objId\", and then--- invoke @handler@:------ > pathVar @"objId" @Int handler----pathVar :: forall tag val ts m a. (FromHttpApiData val, MonadRouter m)-        => RequestMiddleware' m ts (PathVar tag val:ts) a-pathVar handler = Kleisli $-  probe @(PathVar tag val) >=> either (const rejectRoute) (runKleisli handler)---- | 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:------ +---------------------------------------+---------------------------------------------------------------------------------------+--- | 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  = 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"-  }---- | 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 p []                    = [p]-    joinPath (p:|[]) ((p':|[]) : xs) = ((p <> "/" <> p') :| []) : xs-    joinPath y (x:xs)                = y:x:xs--    toPathExp :: NonEmpty String -> Q Exp-    toPathExp (p :| [])  = pure $ AppTypeE (VarE 'path) (LitT $ StrTyLit p)-    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 ".")
− src/WebGear/Modifiers.hs 
@@ -1,18 +0,0 @@--- |--- 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
+ src/WebGear/Server.hs view
@@ -0,0 +1,39 @@+{- | Main module for WebGear server.++ Import this module to get all required types and functions to build a+ WebGear server. Alternatively, import individual modules under+ @WebGear.Server@.++ Typical usage to implement a server is:++@+ import WebGear.Server+ import Network.Wai (Application)+ import qualified Network.Wai.Handler.Warp as Warp++ -- | A monad stack for you application+ type App a = ....++ -- | Convert the App monad to IO+ runApp :: App a -> IO a+ runApp = ....++ -- | Handler for the server+ myHandler :: `Handler` h App => `RequestHandler` h '[]+ myHandler = ....++ app :: Application+ app = `toApplication` (`transform` runApp myHandler)++ main :: IO ()+ main = Warp.run port app+@+-}+module WebGear.Server (+  module WebGear.Core,+  module WebGear.Server.Handler,+) where++import WebGear.Core+import WebGear.Server.Handler+import WebGear.Server.Traits ()
+ src/WebGear/Server/Handler.hs view
@@ -0,0 +1,183 @@+{- |+ Server implementation of WebGear handlers+-}+module WebGear.Server.Handler (+  ServerHandler (..),+  RoutePath (..),+  runServerHandler,+  toApplication,+  transform,+) where++import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..))+import Control.Arrow.Operations (ArrowError (..))+import qualified Control.Category as Cat+import Data.ByteString (ByteString)+import Data.Either (fromRight)+import qualified Data.HashMap.Strict as HM+import Data.String (fromString)+import Data.Version (showVersion)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai+import Paths_webgear_server (version)+import WebGear.Core.Handler (Description, Handler (..), RouteMismatch (..), RoutePath (..), Summary)+import WebGear.Core.Request (Request (..))+import WebGear.Core.Response (Response (..), toWaiResponse)+import WebGear.Core.Trait (Linked, linkzero)++{- | An arrow implementing a WebGear server.++ It can be thought of equivalent to the function arrow @a -> m b@+ where @m@ is a monad. It also supports routing and possibly failing+ the computation when the route does not match.+-}+newtype ServerHandler m a b = ServerHandler {unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}++instance Monad m => Cat.Category (ServerHandler m) where+  {-# INLINEABLE id #-}+  id = ServerHandler $ \(a, s) -> pure (Right a, s)++  {-# INLINEABLE (.) #-}+  ServerHandler f . ServerHandler g = ServerHandler $ \(a, s) ->+    g (a, s) >>= \case+      (Left e, s') -> pure (Left e, s')+      (Right b, s') -> f (b, s')++instance Monad m => Arrow (ServerHandler m) where+  arr f = ServerHandler (\(a, s) -> pure (Right (f a), s))++  {-# INLINEABLE first #-}+  first (ServerHandler f) = ServerHandler $ \((a, c), s) ->+    f (a, s) >>= \case+      (Left e, s') -> pure (Left e, s')+      (Right b, s') -> pure (Right (b, c), s')++  {-# INLINEABLE second #-}+  second (ServerHandler f) = ServerHandler $ \((c, a), s) ->+    f (a, s) >>= \case+      (Left e, s') -> pure (Left e, s')+      (Right b, s') -> pure (Right (c, b), s')++instance Monad m => ArrowZero (ServerHandler m) where+  {-# INLINEABLE zeroArrow #-}+  zeroArrow = ServerHandler (\(_a, s) -> pure (Left mempty, s))++instance Monad m => ArrowPlus (ServerHandler m) where+  {-# INLINEABLE (<+>) #-}+  ServerHandler f <+> ServerHandler g = ServerHandler $ \(a, s) ->+    f (a, s) >>= \case+      (Left _e, _s') -> g (a, s)+      (Right b, s') -> pure (Right b, s')++instance Monad m => ArrowChoice (ServerHandler m) where+  {-# INLINEABLE left #-}+  left (ServerHandler f) = ServerHandler $ \(bd, s) ->+    case bd of+      Right d -> pure (Right (Right d), s)+      Left b ->+        f (b, s) >>= \case+          (Left e, s') -> pure (Left e, s')+          (Right c, s') -> pure (Right (Left c), s')++  {-# INLINEABLE right #-}+  right (ServerHandler f) = ServerHandler $ \(db, s) ->+    case db of+      Left d -> pure (Right (Left d), s)+      Right b ->+        f (b, s) >>= \case+          (Left e, s') -> pure (Left e, s')+          (Right c, s') -> pure (Right (Right c), s')++instance Monad m => ArrowError RouteMismatch (ServerHandler m) where+  {-# INLINEABLE raise #-}+  raise = ServerHandler $ \(e, s) -> pure (Left e, s)++  {-# INLINEABLE handle #-}+  (ServerHandler action) `handle` (ServerHandler errHandler) = ServerHandler $ \(a, s) ->+    action (a, s) >>= \case+      (Left e, s') -> errHandler ((a, e), s')+      (Right b, s') -> pure (Right b, s')++  {-# INLINEABLE tryInUnless #-}+  tryInUnless (ServerHandler action) (ServerHandler resHandler) (ServerHandler errHandler) =+    ServerHandler $ \(a, s) ->+      action (a, s) >>= \case+        (Left e, s') -> errHandler ((a, e), s')+        (Right b, s') -> resHandler ((a, b), s')++instance Monad m => Handler (ServerHandler m) m where+  {-# INLINEABLE arrM #-}+  arrM :: (a -> m b) -> ServerHandler m a b+  arrM f = ServerHandler $ \(a, s) -> f a >>= \b -> pure (Right b, s)++  {-# INLINEABLE consumeRoute #-}+  consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a+  consumeRoute (ServerHandler h) = ServerHandler $+    \((), path) -> h (path, RoutePath [])++  {-# INLINEABLE setDescription #-}+  setDescription :: Description -> ServerHandler m a a+  setDescription _ = Cat.id++  {-# INLINEABLE setSummary #-}+  setSummary :: Summary -> ServerHandler m a a+  setSummary _ = Cat.id++-- | Run a ServerHandler to produce a result or a route mismatch error.+runServerHandler ::+  Monad m =>+  -- | The handler to run+  ServerHandler m a b ->+  -- | Path used for routing+  RoutePath ->+  -- | Input value to the arrow+  a ->+  -- | The result of the arrow+  m (Either RouteMismatch b)+runServerHandler (ServerHandler h) path a = fst <$> h (a, path)++-- | Convert a ServerHandler to a WAI application+toApplication :: ServerHandler IO (Linked '[] Request) Response -> Wai.Application+toApplication h rqt cont =+  runServerHandler h path request+    >>= cont . toWaiResponse . addServerHeader . mkWebGearResponse+  where+    request :: Linked '[] Request+    request = linkzero $ Request rqt++    path :: RoutePath+    path = RoutePath $ Wai.pathInfo rqt++    mkWebGearResponse :: Either RouteMismatch Response -> Response+    mkWebGearResponse = fromRight (Response HTTP.notFound404 [] mempty)++    addServerHeader :: Response -> Response+    addServerHeader resp@Response{..} = resp{responseHeaders = responseHeaders <> webGearServerHeader}++{- | Transform a `ServerHandler` running in one monad to another monad.++ This is useful in cases where the server is running in a custom+ monad but you would like to convert it to a WAI application using+ `toApplication`.++ Example usage with a ReaderT monad stack:++@+ `toApplication` (transform f server)+   where+     server :: `ServerHandler` (ReaderT r IO) (`Linked` '[] `Request`) `Response`+     server = ....++     f :: ReaderT r IO a -> IO a+     f action = runReaderT action r+@+-}+transform ::+  (forall x. m x -> n x) ->+  ServerHandler m a b ->+  ServerHandler n a b+transform f (ServerHandler g) =+  ServerHandler $ f . g++webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString+webGearServerHeader = HM.singleton HTTP.hServer (fromString $ "WebGear/" ++ showVersion version)
+ src/WebGear/Server/Trait/Auth/Basic.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the 'BasicAuth'' trait.+module WebGear.Server.Trait.Auth.Basic where++import Control.Arrow (arr, returnA, (>>>))+import Data.Bifunctor (first)+import Data.ByteString.Base64 (decodeLenient)+import Data.ByteString.Char8 (intercalate, split)+import Data.Void (Void)+import WebGear.Core.Handler (arrM)+import WebGear.Core.Modifiers+import WebGear.Core.Request (Request)+import WebGear.Core.Trait (Get (..), Linked)+import WebGear.Core.Trait.Auth.Basic (+  BasicAuth' (..),+  BasicAuthError (..),+  Credentials (..),+  Password (..),+  Username (..),+ )+import WebGear.Core.Trait.Auth.Common (+  AuthToken (..),+  AuthorizationHeader,+  getAuthorizationHeaderTrait,+ )+import WebGear.Server.Handler (ServerHandler)++instance+  ( Monad m+  , Get (ServerHandler m) (AuthorizationHeader scheme) Request+  ) =>+  Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request+  where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    BasicAuth' Required scheme m e a ->+    ServerHandler m (Linked ts Request) (Either (BasicAuthError e) a)+  getTrait BasicAuth'{..} = proc request -> do+    result <- getAuthorizationHeaderTrait @scheme -< request+    case result of+      Nothing -> returnA -< Left BasicAuthHeaderMissing+      (Just (Left _)) -> returnA -< Left BasicAuthSchemeMismatch+      (Just (Right token)) ->+        case parseCreds token of+          Left e -> returnA -< Left e+          Right c -> validateCreds -< c+    where+      parseCreds :: AuthToken scheme -> Either (BasicAuthError e) Credentials+      parseCreds AuthToken{..} =+        case split ':' (decodeLenient authToken) of+          [] -> Left BasicAuthCredsBadFormat+          u : ps -> Right $ Credentials (Username u) (Password $ intercalate ":" ps)++      validateCreds :: ServerHandler m Credentials (Either (BasicAuthError e) a)+      validateCreds = arrM $ \creds -> do+        res <- toBasicAttribute creds+        pure $ first BasicAuthAttributeError res++instance+  ( Monad m+  , Get (ServerHandler m) (AuthorizationHeader scheme) Request+  ) =>+  Get (ServerHandler m) (BasicAuth' Optional scheme m e a) Request+  where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    BasicAuth' Optional scheme m e a ->+    ServerHandler m (Linked ts Request) (Either Void (Either (BasicAuthError e) a))+  getTrait BasicAuth'{..} = getTrait (BasicAuth'{..} :: BasicAuth' Required scheme m e a) >>> arr Right
+ src/WebGear/Server/Trait/Auth/JWT.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the 'JWTAuth'' trait.+module WebGear.Server.Trait.Auth.JWT where++import Control.Arrow (arr, returnA, (>>>))+import Control.Monad.Except (MonadError (throwError), lift, runExceptT, withExceptT)+import Control.Monad.Time (MonadTime)+import qualified Crypto.JWT as JWT+import Data.ByteString.Lazy (fromStrict)+import Data.Void (Void)+import WebGear.Core.Handler (arrM)+import WebGear.Core.Modifiers+import WebGear.Core.Request (Request)+import WebGear.Core.Trait (Get (..), Linked)+import WebGear.Core.Trait.Auth.Common (+  AuthToken (..),+  AuthorizationHeader,+  getAuthorizationHeaderTrait,+ )+import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..), JWTAuthError (..))+import WebGear.Server.Handler (ServerHandler)++instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Required scheme m e a) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    JWTAuth' Required scheme m e a ->+    ServerHandler m (Linked ts Request) (Either (JWTAuthError e) a)+  getTrait JWTAuth'{..} = proc request -> do+    result <- getAuthorizationHeaderTrait @scheme -< request+    case result of+      Nothing -> returnA -< Left JWTAuthHeaderMissing+      (Just (Left _)) -> returnA -< Left JWTAuthSchemeMismatch+      (Just (Right token)) ->+        case parseJWT token of+          Left e -> returnA -< Left (JWTAuthTokenBadFormat e)+          Right jwt -> validateJWT -< jwt+    where+      parseJWT :: AuthToken scheme -> Either JWT.JWTError JWT.SignedJWT+      parseJWT AuthToken{..} = JWT.decodeCompact $ fromStrict authToken++      validateJWT :: ServerHandler m JWT.SignedJWT (Either (JWTAuthError e) a)+      validateJWT = arrM $ \jwt -> runExceptT $ do+        claims <- withExceptT JWTAuthTokenBadFormat $ JWT.verifyClaims jwtValidationSettings jwkSet jwt+        lift (toJWTAttribute claims) >>= either (throwError . JWTAuthAttributeError) pure++instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Optional scheme m e a) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    JWTAuth' Optional scheme m e a ->+    ServerHandler m (Linked ts Request) (Either Void (Either (JWTAuthError e) a))+  getTrait JWTAuth'{..} = getTrait (JWTAuth'{..} :: JWTAuth' Required scheme m e a) >>> arr Right
+ src/WebGear/Server/Trait/Body.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `Body` trait.+module WebGear.Server.Trait.Body () where++import Control.Arrow (returnA)+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.Aeson as Aeson+import Data.ByteString.Conversion (FromByteString, ToByteString, parser, runParser', toByteString)+import Data.ByteString.Lazy (fromChunks)+import Data.Text (Text, pack)+import Network.HTTP.Media.RenderHeader (RenderHeader (renderHeader))+import Network.HTTP.Types (hContentType)+import WebGear.Core.Handler (Handler (..))+import WebGear.Core.Request (Request, getRequestBodyChunk)+import WebGear.Core.Response (Response (..))+import WebGear.Core.Trait (Get (..), Linked, Set (..), unlink)+import WebGear.Core.Trait.Body (Body (..), JSONBody (..))+import WebGear.Server.Handler (ServerHandler)++instance (MonadIO m, FromByteString val) => Get (ServerHandler m) (Body val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: Body val -> ServerHandler m (Linked ts Request) (Either Text val)+  getTrait (Body _) = arrM $ \request -> do+    chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request+    pure $ case runParser' parser (fromChunks chunks) of+      Left e -> Left $ pack e+      Right t -> Right t++instance (Monad m, ToByteString val) => Set (ServerHandler m) (Body val) Response where+  {-# INLINEABLE setTrait #-}+  setTrait ::+    Body val ->+    (Linked ts Response -> Response -> val -> Linked (Body val : ts) Response) ->+    ServerHandler m (Linked ts Response, val) (Linked (Body val : ts) Response)+  setTrait (Body mediaType) f = proc (linkedResponse, val) -> do+    let response = (unlink linkedResponse)+        response' =+          response+            { responseBody = Just (toByteString val)+            , responseHeaders =+                responseHeaders response+                  <> case mediaType of+                    Just mt -> [(hContentType, renderHeader mt)]+                    Nothing -> []+            }+    returnA -< f linkedResponse response' val++instance (MonadIO m, Aeson.FromJSON val) => Get (ServerHandler m) (JSONBody val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: JSONBody val -> ServerHandler m (Linked ts Request) (Either Text val)+  getTrait (JSONBody _) = arrM $ \request -> do+    chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request+    pure $ case Aeson.eitherDecode' (fromChunks chunks) of+      Left e -> Left $ pack e+      Right t -> Right t++instance (Monad m, Aeson.ToJSON val) => Set (ServerHandler m) (JSONBody val) Response where+  {-# INLINEABLE setTrait #-}+  setTrait ::+    JSONBody val ->+    (Linked ts Response -> Response -> val -> Linked (JSONBody val : ts) Response) ->+    ServerHandler m (Linked ts Response, val) (Linked (JSONBody val : ts) Response)+  setTrait (JSONBody mediaType) f = proc (linkedResponse, val) -> do+    let response = unlink linkedResponse+        ctype = maybe "application/json" renderHeader mediaType+        response' =+          response+            { responseBody = Just (Aeson.encode val)+            , responseHeaders =+                responseHeaders response+                  <> [(hContentType, ctype)]+            }+    returnA -< f linkedResponse response' val++takeWhileM :: Monad m => (a -> Bool) -> [m a] -> m [a]+takeWhileM _ [] = pure []+takeWhileM p (mx : mxs) = do+  x <- mx+  if p x+    then (x :) <$> takeWhileM p mxs+    else pure []
+ src/WebGear/Server/Trait/Header.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `Header` trait.+module WebGear.Server.Trait.Header () where++import Control.Arrow (arr, returnA, (>>>))+import Data.ByteString.Conversion (ToByteString, toByteString')+import qualified Data.HashMap.Strict as HM+import Data.Proxy (Proxy (Proxy))+import Data.String (fromString)+import Data.Text (Text)+import Data.Void (Void)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types (HeaderName)+import Web.HttpApiData (FromHttpApiData, parseHeader)+import WebGear.Core.Modifiers+import WebGear.Core.Request (Request, requestHeader)+import WebGear.Core.Response (Response (..))+import WebGear.Core.Trait (Get (..), Linked, Set (..), unlink)+import WebGear.Core.Trait.Header (Header (..), HeaderNotFound (..), HeaderParseError (..))+import WebGear.Server.Handler (ServerHandler)++extractRequestHeader ::+  (Monad m, KnownSymbol name, FromHttpApiData val) =>+  Proxy name ->+  ServerHandler m (Linked ts Request) (Maybe (Either Text val))+extractRequestHeader proxy = proc req -> do+  let headerName :: HeaderName = fromString $ symbolVal proxy+  returnA -< parseHeader <$> requestHeader headerName (unlink req)++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Strict name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    Header Required Strict name val ->+    ServerHandler m (Linked ts Request) (Either (Either HeaderNotFound HeaderParseError) val)+  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Left $ Left HeaderNotFound+        Just (Left e) -> Left $ Right $ HeaderParseError e+        Just (Right x) -> Right x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Strict name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    Header Optional Strict name val ->+    ServerHandler m (Linked ts Request) (Either HeaderParseError (Maybe val))+  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Right Nothing+        Just (Left e) -> Left $ HeaderParseError e+        Just (Right x) -> Right $ Just x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Lenient name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    Header Required Lenient name val ->+    ServerHandler m (Linked ts Request) (Either HeaderNotFound (Either Text val))+  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Left HeaderNotFound+        Just (Left e) -> Right $ Left e+        Just (Right x) -> Right $ Right x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Lenient name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    Header Optional Lenient name val ->+    ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))+  getTrait Header = extractRequestHeader (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Right Nothing+        Just (Left e) -> Right $ Just $ Left e+        Just (Right x) -> Right $ Just $ Right x++instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Required Strict name val) Response where+  {-# INLINEABLE setTrait #-}+  setTrait ::+    Header Required Strict name val ->+    (Linked ts Response -> Response -> val -> Linked (Header Required Strict name val : ts) Response) ->+    ServerHandler m (Linked ts Response, val) (Linked (Header Required Strict name val : ts) Response)+  setTrait Header f = proc (l, val) -> do+    let headerName :: HeaderName = fromString $ symbolVal $ Proxy @name+        response@Response{..} = unlink l+        response' = response{responseHeaders = HM.insert headerName (toByteString' val) responseHeaders}+    returnA -< f l response' val++instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Optional Strict name val) Response where+  {-# INLINEABLE setTrait #-}+  setTrait ::+    Header Optional Strict name val ->+    (Linked ts Response -> Response -> Maybe val -> Linked (Header Optional Strict name val : ts) Response) ->+    ServerHandler m (Linked ts Response, Maybe val) (Linked (Header Optional Strict name val : ts) Response)+  setTrait Header f = proc (l, maybeVal) -> do+    let headerName :: HeaderName = fromString $ symbolVal $ Proxy @name+        response@Response{..} = unlink l+        response' = response{responseHeaders = HM.alter (const $ toByteString' <$> maybeVal) headerName responseHeaders}+    returnA -< f l response' maybeVal
+ src/WebGear/Server/Trait/Method.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `Method` trait.+module WebGear.Server.Trait.Method where++import Control.Arrow (returnA)+import qualified Network.HTTP.Types as HTTP+import WebGear.Core.Request (Request, requestMethod)+import WebGear.Core.Trait (Get (..), Linked, unlink)+import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..))+import WebGear.Server.Handler (ServerHandler)++instance Monad m => Get (ServerHandler m) Method Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: Method -> ServerHandler m (Linked ts Request) (Either MethodMismatch HTTP.StdMethod)+  getTrait (Method method) = proc request -> do+    let expectedMethod = HTTP.renderStdMethod method+        actualMethod = requestMethod $ unlink request+    if actualMethod == expectedMethod+      then returnA -< Right method+      else returnA -< Left $ MethodMismatch{..}
+ src/WebGear/Server/Trait/Path.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the path traits.+module WebGear.Server.Trait.Path where++import qualified Data.List as List+import qualified Data.Text as Text+import Web.HttpApiData (FromHttpApiData (..))+import WebGear.Core.Handler (RoutePath (..))+import WebGear.Core.Request (Request)+import WebGear.Core.Trait (Get (..), Linked)+import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..))+import WebGear.Server.Handler (ServerHandler (..))++instance Monad m => Get (ServerHandler m) Path Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: Path -> ServerHandler m (Linked ts Request) (Either () ())+  getTrait (Path p) = ServerHandler $ \(_, path@(RoutePath remaining)) -> do+    let expected = filter (/= "") $ Text.splitOn "/" p+    pure $ case List.stripPrefix expected remaining of+      Just ps -> (Right (Right ()), RoutePath ps)+      Nothing -> (Right (Left ()), path)++instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: PathVar tag val -> ServerHandler m (Linked ts Request) (Either PathVarError val)+  getTrait PathVar = ServerHandler $ \(_, path@(RoutePath remaining)) -> do+    pure $ case remaining of+      [] -> (Right (Left PathVarNotFound), path)+      (p : ps) ->+        case parseUrlPiece p of+          Left e -> (Right (Left $ PathVarParseError e), path)+          Right val -> (Right (Right val), RoutePath ps)++instance Monad m => Get (ServerHandler m) PathEnd Request where+  {-# INLINEABLE getTrait #-}+  getTrait :: PathEnd -> ServerHandler m (Linked ts Request) (Either () ())+  getTrait PathEnd = ServerHandler f+    where+      f (_, p@(RoutePath [])) = pure (Right $ Right (), p)+      f (_, p) = pure (Right $ Left (), p)
+ src/WebGear/Server/Trait/QueryParam.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `QueryParam` trait.+module WebGear.Server.Trait.QueryParam () where++import Control.Arrow (arr, returnA, (>>>))+import Data.List (find)+import Data.Proxy (Proxy (Proxy))+import Data.String (fromString)+import Data.Text (Text)+import Data.Void (Void)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types (queryToQueryText)+import Web.HttpApiData (FromHttpApiData (..))+import WebGear.Core.Modifiers+import WebGear.Core.Request (Request, queryString)+import WebGear.Core.Trait (Get (..), Linked, unlink)+import WebGear.Core.Trait.QueryParam (+  ParamNotFound (..),+  ParamParseError (..),+  QueryParam (..),+ )+import WebGear.Server.Handler (ServerHandler)++extractQueryParam ::+  (Monad m, KnownSymbol name, FromHttpApiData val) =>+  Proxy name ->+  ServerHandler m (Linked ts Request) (Maybe (Either Text val))+extractQueryParam proxy = proc req -> do+  let name = fromString $ symbolVal proxy+      params = queryToQueryText $ queryString $ unlink req+  returnA -< parseQueryParam <$> (find ((== name) . fst) params >>= snd)++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Strict name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    QueryParam Required Strict name val ->+    ServerHandler m (Linked ts Request) (Either (Either ParamNotFound ParamParseError) val)+  getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Left $ Left ParamNotFound+        Just (Left e) -> Left $ Right $ ParamParseError e+        Just (Right x) -> Right x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Strict name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    QueryParam Optional Strict name val ->+    ServerHandler m (Linked ts Request) (Either ParamParseError (Maybe val))+  getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Right Nothing+        Just (Left e) -> Left $ ParamParseError e+        Just (Right x) -> Right $ Just x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Lenient name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    QueryParam Required Lenient name val ->+    ServerHandler m (Linked ts Request) (Either ParamNotFound (Either Text val))+  getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Left ParamNotFound+        Just (Left e) -> Right $ Left e+        Just (Right x) -> Right $ Right x++instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Lenient name val) Request where+  {-# INLINEABLE getTrait #-}+  getTrait ::+    QueryParam Optional Lenient name val ->+    ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))+  getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f+    where+      f = \case+        Nothing -> Right Nothing+        Just (Left e) -> Right $ Just $ Left e+        Just (Right x) -> Right $ Just $ Right x
+ src/WebGear/Server/Trait/Status.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Server implementation of the `Status` trait.+module WebGear.Server.Trait.Status where++import Control.Arrow (returnA)+import qualified Network.HTTP.Types.Status as HTTP+import WebGear.Core.Response (Response (responseStatus))+import WebGear.Core.Trait (Linked, Set, setTrait, unlink)+import WebGear.Core.Trait.Status (Status (..))+import WebGear.Server.Handler (ServerHandler)++instance Monad m => Set (ServerHandler m) Status Response where+  {-# INLINEABLE setTrait #-}+  setTrait ::+    Status ->+    (Linked ts Response -> Response -> HTTP.Status -> Linked (Status : ts) Response) ->+    ServerHandler m (Linked ts Response, HTTP.Status) (Linked (Status : ts) Response)+  setTrait (Status status) f = proc (linkedResponse, _) -> do+    let response = unlink linkedResponse+        response' = response{responseStatus = status}+    returnA -< f linkedResponse response' status
+ src/WebGear/Server/Traits.hs view
@@ -0,0 +1,15 @@+{- | Server implementation of all traits supported by WebGear.++ This modules only exports orphan instances imported from other+ modules. Hence the haddock documentation will be empty.+-}+module WebGear.Server.Traits () where++import WebGear.Server.Trait.Auth.Basic ()+import WebGear.Server.Trait.Auth.JWT ()+import WebGear.Server.Trait.Body ()+import WebGear.Server.Trait.Header ()+import WebGear.Server.Trait.Method ()+import WebGear.Server.Trait.Path ()+import WebGear.Server.Trait.QueryParam ()+import WebGear.Server.Trait.Status ()
− src/WebGear/Trait.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ 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 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.----module WebGear.Trait-  ( -- * Core Types-    Trait (..)-  , Result (..)-  , Linked--    -- * 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.Proxy (Proxy (..))-import GHC.TypeLits (ErrorMessage (..), TypeError)----- | 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 when the trait holds for a-  -- value-  type Attribute t a :: Type--  -- | 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--  -- | 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)----- | 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 derivable trait that is always present and whose--- attribute does not carry any meaningful information.-instance Monad m => Trait '[] a m where-  type Attribute '[] a = ()-  type Absence '[] a = ()--  toAttribute :: a -> m (Result '[] a)-  toAttribute = const $ pure $ Found ()---- | 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)--  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)----- | A value linked with a type-level list of traits.-data Linked (ts :: [Type]) a = Linked-    { linkAttribute :: !(Attribute ts a)-    , unlink        :: !a                 -- ^ Retrive the value from a linked value-    }---- | 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--- 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 :: 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 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 in the list--- of traits @ts@.-class Has t ts where-  -- | 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-  get :: Proxy t -> Linked (t:ts) a -> Attribute t a-  get _ (Linked (lv, _) _) = lv--instance {-# OVERLAPPABLE #-} Has t ts => Has t (t':ts) where-  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--- 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)
− src/WebGear/Types.hs 
@@ -1,470 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Common types and functions used throughout WebGear.----module WebGear.Types-  ( -- * WebGear Request-    Request-  , remoteHost-  , httpVersion-  , isSecure-  , requestMethod-  , pathInfo-  , queryString-  , requestHeader-  , requestHeaders-  , requestBodyLength-  , getRequestBodyChunk--    -- * WebGear Response-  , Response (..)-  , responseHeader-  , setResponseHeader-  , waiResponse--    -- * 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.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 Data.Version (showVersion)-import GHC.Exts (fromList)-import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString,-                    remoteHost, requestBodyLength, requestHeaders, requestMethod)--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 :: HTTP.HeaderName -> Request -> Maybe ByteString-requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r)---- | 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-    { 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-  responseStatus-  (HM.toList responseHeaders)-  (fromMaybe "" responseBody)----- | 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.-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.------ A middleware can do a number of things with the request--- handling such as:------   * Change the request traits before invoking the handler.---   * Use the linked value of any of the request traits.---   * Change the response body.----type Middleware' m req req' a' a = Handler' m req' a' -> Handler' m req 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 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
− src/WebGear/Util.hs 
@@ -1,32 +0,0 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com------ Common utility functions.-module WebGear.Util-  ( takeWhileM-  , splitOn-  , maybeToRight-  ) where--import Data.List.NonEmpty (NonEmpty (..), toList)---takeWhileM :: Monad m => (a -> Bool) -> [m a] -> m [a]-takeWhileM _    []     = pure []-takeWhileM p (mx:mxs) = do-  x <- mx-  if p x-    then (x :) <$> takeWhileM p mxs-    else pure []--splitOn :: Eq a => a -> [a] -> NonEmpty [a]-splitOn sep = foldr f ([] :| [])-  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
test/Main.hs view
@@ -1,15 +1,9 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com--- module Main where  import Test.Tasty (TestTree, defaultMain, testGroup)  import Properties (propertyTests) import Unit (unitTests)-  main :: IO () main = defaultMain allTests
test/Properties.hs view
@@ -1,11 +1,6 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com----module Properties-  ( propertyTests-  ) where+module Properties (+  propertyTests,+) where  import Test.Tasty (TestTree, testGroup) @@ -13,15 +8,17 @@ 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-+import qualified Properties.Trait.QueryParam as QueryParam  propertyTests :: TestTree-propertyTests = testGroup "Property Tests" [ Method.tests-                                           , Path.tests-                                           , Header.tests-                                           , Params.tests-                                           , Body.tests-                                           , Basic.tests-                                           ]+propertyTests =+  testGroup+    "Property Tests"+    [ Method.tests+    , Path.tests+    , Header.tests+    , QueryParam.tests+    , Body.tests+    , Basic.tests+    ]
test/Properties/Trait/Auth/Basic.hs view
@@ -1,22 +1,40 @@-module Properties.Trait.Auth.Basic-  ( tests-  ) where+module Properties.Trait.Auth.Basic (+  tests,+) where +import Control.Arrow (returnA, (>>>)) 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 Data.Either (fromRight)+import Data.Functor.Identity (Identity, runIdentity)+import Network.Wai (defaultRequest, requestHeaders)+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-+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (Linked, getTrait, linkzero, probe)+import WebGear.Core.Trait.Auth.Basic (+  BasicAuth,+  BasicAuth' (..),+  Credentials (..),+  Password (..),+  Username (..),+ )+import WebGear.Core.Trait.Auth.Common (AuthorizationHeader)+import WebGear.Core.Trait.Header (Header (..))+import WebGear.Server.Handler (ServerHandler, runServerHandler)+import WebGear.Server.Trait.Auth.Basic ()+import WebGear.Server.Trait.Header ()+import Prelude hiding (elem)  prop_basicAuth :: Property prop_basicAuth = property f@@ -24,17 +42,23 @@     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)+        let hval = "Basic " <> encode (username <> ":" <> password) +            mkRequest :: ServerHandler Identity () (Linked '[AuthorizationHeader "Basic"] Request)+            mkRequest = proc () -> do+              let req = Request $ defaultRequest{requestHeaders = [("Authorization", hval)]}+              r <- probe Header -< linkzero req+              returnA -< fromRight undefined r++            authCfg :: BasicAuth Identity () Credentials+            authCfg = BasicAuth'{toBasicAttribute = pure . Right}+         in runIdentity $ do+              res <- runServerHandler (mkRequest >>> getTrait authCfg) [""] ()+              pure $ case res of+                Right (Right creds) ->+                  credentialsUsername creds === Username username+                    .&&. credentialsPassword creds === Password password+                e -> counterexample ("Unexpected failure: " <> show e) (property False)  -- Hack for TH splicing return []
test/Properties/Trait/Body.hs view
@@ -1,8 +1,8 @@ {-# OPTIONS_GHC -Wno-deprecations #-} -module Properties.Trait.Body-  ( tests-  ) where+module Properties.Trait.Body (+  tests,+) where  import Control.Monad.IO.Class (MonadIO, liftIO) import Data.IORef (newIORef, readIORef, writeIORef)@@ -13,39 +13,41 @@ 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.Types+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (Linked, getTrait, linkzero)+import WebGear.Core.Trait.Body (JSONBody (..))+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.Body () +jsonBody :: JSONBody t+jsonBody = JSONBody (Just "application/json") -bodyToRequest :: (MonadIO m, Show a) => a -> m Request+bodyToRequest :: (MonadIO m, Show a) => a -> m (Linked '[] Request) bodyToRequest x = do   body <- liftIO $ newIORef $ Just $ fromString $ show x   let f = readIORef body >>= maybe (pure "") (\s -> writeIORef body Nothing >> pure s)-  return defaultRequest { requestBody = f }+  return $ linkzero $ Request $ defaultRequest{requestBody = f}  prop_emptyRequestBodyFails :: Property prop_emptyRequestBodyFails = monadicIO $ do   req <- bodyToRequest ("" :: String)-  toAttribute @(JSONRequestBody Int) req >>= \case-    Found _    -> monitor (counterexample "Unexpected success") >> assert False-    NotFound _ -> assert True+  runServerHandler (getTrait (jsonBody :: JSONBody Int)) [""] req >>= \case+    Right (Left _) -> assert True+    e -> monitor (counterexample $ "Unexpected " <> show e) >> assert False  prop_validBodyParses :: Property prop_validBodyParses = property $ \n -> monadicIO $ do   req <- bodyToRequest (n :: Integer)-  toAttribute @(JSONRequestBody Integer) req >>= \case-    Found n'   -> assert (n == n')-    NotFound _ -> assert False+  runServerHandler (getTrait jsonBody) [""] req >>= \case+    Right (Right n') -> assert (n == n')+    _ -> assert False -prop_invalidBodyFails :: Property-prop_invalidBodyFails = property $ \n -> monadicIO $ do+prop_invalidBodyTypeFails :: Property+prop_invalidBodyTypeFails = property $ \n -> monadicIO $ do   req <- bodyToRequest (n :: Integer)-  toAttribute @(JSONRequestBody String) req >>= \case-    Found _    -> assert False-    NotFound _ -> assert True-+  runServerHandler (getTrait (jsonBody :: JSONBody String)) [""] req >>= \case+    Right (Left _) -> assert True+    _ -> assert False  -- Hack for TH splicing return []
test/Properties/Trait/Header.hs view
@@ -1,55 +1,40 @@-module Properties.Trait.Header-  ( tests-  ) where+module Properties.Trait.Header (+  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 Network.Wai (defaultRequest, requestHeaders)+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.Types-+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait.Header (Header (..), HeaderParseError (..), RequiredHeader)+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.Header ()  prop_headerParseError :: Property prop_headerParseError = property $ \hval ->-  let-    hval' = "test-" <> hval-    req = defaultRequest { requestHeaders = [("foo", encodeUtf8 hval')] }-  in-    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)")+  let hval' = "test-" <> hval+      req = linkzero $ Request $ defaultRequest{requestHeaders = [("foo", encodeUtf8 hval')]}+   in runIdentity $ do+        res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+        pure $ case res of+          Right (Left e) ->+            e === Right (HeaderParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)")+          v -> counterexample ("Unexpected result: " <> show v) (property False)  prop_headerParseSuccess :: Property prop_headerParseSuccess = property $ \(n :: Int) ->-  let-    req = defaultRequest { requestHeaders = [("foo", fromString $ show n)] }-  in-    case runIdentity (toAttribute @(Header "foo" Int) req) of-      Found n'   -> n === n'-      NotFound e ->-        counterexample ("Unexpected result: " <> show e) (property False)--prop_headerMatch :: Property-prop_headerMatch = property $ \v ->-  let-    req = defaultRequest { requestHeaders = [("foo", v)] }-  in-    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"-+  let req = linkzero $ Request $ defaultRequest{requestHeaders = [("foo", fromString $ show n)]}+   in runIdentity $ do+        res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+        pure $ case res of+          Right (Right n') -> n === n'+          e -> counterexample ("Unexpected result: " <> show e) (property False)  -- Hack for TH splicing return []
test/Properties/Trait/Method.hs view
@@ -1,36 +1,43 @@-module Properties.Trait.Method-  ( tests-  ) where+module Properties.Trait.Method (+  tests,+) where  import Data.Functor.Identity (runIdentity) import Network.HTTP.Types (StdMethod (..), methodGet, renderStdMethod)-import Network.Wai (defaultRequest)-import Test.QuickCheck (Arbitrary (arbitrary), Property, allProperties, elements, property, (.&&.),-                        (=/=), (===))+import Network.Wai (defaultRequest, requestMethod)+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.Types-+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..))+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.Method ()  newtype MethodWrapper = MethodWrapper StdMethod   deriving stock (Show)  instance Arbitrary MethodWrapper where-  arbitrary = elements $ MethodWrapper <$> [minBound..maxBound]+  arbitrary = elements $ MethodWrapper <$> [minBound .. maxBound]  prop_methodMatch :: Property prop_methodMatch = property $ \(MethodWrapper v) ->-  let-    req = defaultRequest { requestMethod = renderStdMethod v }-  in-    case runIdentity (toAttribute @(Method GET) req) of-      Found _    -> v === GET-      NotFound e ->-        expectedMethod e === methodGet .&&. actualMethod e =/= methodGet-+  let req = linkzero $ Request $ defaultRequest{requestMethod = renderStdMethod v}+   in runIdentity $ do+        res <- runServerHandler (getTrait (Method GET)) [""] req+        pure $ case res of+          Right (Right _) -> v === GET+          Right (Left e) -> expectedMethod e === methodGet .&&. actualMethod e =/= methodGet+          Left _ -> property False  -- Hack for TH splicing return []
− test/Properties/Trait/Params.hs 
@@ -1,46 +0,0 @@-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
test/Properties/Trait/Path.hs view
@@ -1,50 +1,51 @@-module Properties.Trait.Path-  ( tests-  ) where+module Properties.Trait.Path (+  tests,+) where -import Control.Monad.State.Strict (evalState)+import Data.Functor.Identity (runIdentity) import Data.String (fromString)-import Network.Wai (defaultRequest)+import Network.Wai (defaultRequest, pathInfo) 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.Types-+import WebGear.Core.Trait.Path (Path (..), PathVar (..), PathVarError (..))+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Server.Handler (RoutePath (..), runServerHandler)+import WebGear.Server.Trait.Path ()  prop_pathMatch :: Property prop_pathMatch = property $ \h ->-  let-    rest = ["foo", "bar"]-    req = defaultRequest { pathInfo = h:rest }-  in-    case evalState (toAttribute @(Path "a") req) (PathInfo $ h:rest) of-      Found _    -> h === "a"-      NotFound _ -> h =/= "a"+  let rest = ["foo", "bar"]+      req = linkzero $ Request $ defaultRequest{pathInfo = h : rest}+   in runIdentity $ do+        res <- runServerHandler (getTrait $ Path "a") (RoutePath $ h : rest) req+        pure $ case res of+          Right (Right _) -> h === "a"+          Right (Left _) -> h =/= "a"+          Left _ -> property False  prop_pathVarMatch :: Property prop_pathVarMatch = property $ \(n :: Int) ->-  let-    rest = ["foo", "bar"]-    req = defaultRequest { pathInfo = fromString (show n):rest }-  in-    case evalState (toAttribute @(PathVar "tag" Int) req) (PathInfo $ pathInfo req) of-      Found n'   -> n' === n-      NotFound _ -> property False+  let rest = ["foo", "bar"]+      p = fromString (show n) : rest+      req = linkzero $ Request $ defaultRequest{pathInfo = p}+   in runIdentity $ do+        res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath p) req+        pure $ case res of+          Right (Right n') -> n' === n+          _ -> property False  prop_pathVarParseError :: Property prop_pathVarParseError = property $ \(p, ps) ->-  let-    p' = "test-" <> p-    req = defaultRequest { pathInfo = p':ps }-  in-    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)")-+  let p' = "test-" <> p+      req = linkzero $ Request $ defaultRequest{pathInfo = p' : ps}+   in runIdentity $ do+        res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath $ p' : ps) req+        pure $ case res of+          Right (Left e) -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)")+          _ -> property False  -- Hack for TH splicing return []
+ test/Properties/Trait/QueryParam.hs view
@@ -0,0 +1,44 @@+module Properties.Trait.QueryParam (+  tests,+) where++import Data.Functor.Identity (runIdentity)+import Data.String (fromString)+import Data.Text.Encoding (encodeUtf8)+import Network.Wai (defaultRequest, queryString)+import Test.QuickCheck (Property, allProperties, counterexample, property, (===))+import Test.QuickCheck.Instances ()+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperties)+import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait.QueryParam (ParamParseError (..), QueryParam (..))+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.QueryParam ()++prop_paramParseError :: Property+prop_paramParseError = property $ \hval ->+  let hval' = "test-" <> hval+      req = linkzero $ Request $ defaultRequest{queryString = [("foo", Just $ encodeUtf8 hval')]}+   in runIdentity $ do+        res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req+        pure $ case res of+          Right (Left e) ->+            e === Right (ParamParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)")+          v -> counterexample ("Unexpected result: " <> show v) (property False)++prop_paramParseSuccess :: Property+prop_paramParseSuccess = property $ \(n :: Int) ->+  let req = linkzero $ Request $ defaultRequest{queryString = [("foo", Just $ fromString $ show n)]}+   in runIdentity $ do+        res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req+        pure $ case res of+          Right (Right n') -> n === n'+          e -> counterexample ("Unexpected result: " <> show e) (property False)++-- Hack for TH splicing+return []++tests :: TestTree+tests = testProperties "Trait.Params" $allProperties
test/Unit.hs view
@@ -1,19 +1,16 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com----module Unit-  ( unitTests-  ) where+module Unit (+  unitTests,+) where  import Test.Tasty (TestTree, testGroup)  import qualified Unit.Trait.Header as Header import qualified Unit.Trait.Path as Path - unitTests :: TestTree-unitTests = testGroup "Unit Tests" [ Header.tests-                                   , Path.tests-                                   ]+unitTests =+  testGroup+    "Unit Tests"+    [ Header.tests+    , Path.tests+    ]
test/Unit/Trait/Header.hs view
@@ -1,44 +1,25 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com----module Unit.Trait.Header-  ( tests-  ) where+module Unit.Trait.Header (+  tests,+) where -import Network.Wai (defaultRequest)+import Data.Functor.Identity (runIdentity)+import Network.Wai (defaultRequest, requestHeaders) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=))--import WebGear.Middlewares.Header-import WebGear.Trait-import WebGear.Types-+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Core.Trait.Header (Header (..), HeaderNotFound (..), RequiredHeader)+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.Header ()  testMissingHeaderFails :: TestTree testMissingHeaderFails = testCase "Missing header fails Header trait" $ do-  let req = defaultRequest { requestHeaders = [] }-  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")] }-  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 = [] }-  toAttribute @(HeaderMatch "foo" "bar") req >>= \case-    Found _      -> assertFailure "unexpected success"-    NotFound e -> e @?= Nothing+  let req = linkzero $ Request $ defaultRequest{requestHeaders = []}+  runIdentity $ do+    res <- runServerHandler (getTrait (Header :: RequiredHeader "foo" Int)) [""] req+    pure $ case res of+      Right (Left e) -> e @?= Left HeaderNotFound+      _ -> assertFailure "unexpected success"  tests :: TestTree-tests = testGroup "Trait.Header" [ testMissingHeaderFails-                                 , testHeaderMatchPositive-                                 , testHeaderMatchMissingHeader-                                 ]+tests = testGroup "Trait.Header" [testMissingHeaderFails]
test/Unit/Trait/Path.hs view
@@ -1,28 +1,25 @@--- |--- Copyright        : (c) Raghu Kaippully, 2020--- License          : MPL-2.0--- Maintainer       : rkaippully@gmail.com----module Unit.Trait.Path-  ( tests-  ) where+module Unit.Trait.Path (+  tests,+) where -import Control.Monad.State (evalState)-import Network.Wai (defaultRequest)+import Data.Functor.Identity (runIdentity)+import Network.Wai (defaultRequest, pathInfo) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=))--import WebGear.Middlewares.Path-import WebGear.Trait-import WebGear.Types-+import WebGear.Core.Trait.Path (PathVar (..), PathVarError (..))+import WebGear.Core.Request (Request (..))+import WebGear.Core.Trait (getTrait, linkzero)+import WebGear.Server.Handler (runServerHandler)+import WebGear.Server.Trait.Path ()  testMissingPathVar :: TestTree testMissingPathVar = testCase "PathVar match: missing variable" $ do-  let req = defaultRequest { pathInfo = [] }-  case evalState (toAttribute @(PathVar "tag" Int) req) (PathInfo []) of-    Found _    -> assertFailure "unexpected success"-    NotFound e -> e @?= PathVarNotFound+  let req = linkzero $ Request $ defaultRequest{pathInfo = []}+  runIdentity $ do+    res <- runServerHandler (getTrait (PathVar @"tag" @Int)) [] req+    pure $ case res of+      Right (Left e) -> e @?= PathVarNotFound+      _ -> assertFailure "unexpected success"  tests :: TestTree-tests = testGroup "Trait.Path" [ testMissingPathVar ]+tests = testGroup "Trait.Path" [testMissingPathVar]
webgear-server.cabal view
@@ -1,15 +1,13 @@ cabal-version:       2.4 name:                webgear-server-version:             0.2.1+version:             1.0.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.--        WebGear focuses on good documentation and usability.--        See the documentation of WebGear module to get started.-homepage:            https://github.com/rkaippully/webgear#readme-bug-reports:         https://github.com/rkaippully/webgear/issues+    WebGear is a library to for building composable, type-safe HTTP API servers.+    WebGear focuses on good documentation and usability. See the documentation+    of WebGear module to get started.+homepage:            https://github.com/haskell-webgear/webgear#readme+bug-reports:         https://github.com/haskell-webgear/webgear/issues author:              Raghu Kaippully maintainer:          rkaippully@gmail.com copyright:           2020 Raghu Kaippully@@ -18,76 +16,91 @@ category:            Web build-type:          Simple extra-source-files:  README.md-                     ChangeLog.md+                     CHANGELOG.md   source-repository head   type:      git-  location:  https://github.com/rkaippully/webgear+  location:  https://github.com/haskell-webgear/webgear   common webgear-common   default-language:   Haskell2010-  default-extensions: DataKinds+  default-extensions: Arrows+                      ConstraintKinds+                      DataKinds                       DeriveFunctor+                      DeriveGeneric                       DerivingStrategies+                      DerivingVia                       FlexibleContexts                       FlexibleInstances+                      FunctionalDependencies                       GeneralizedNewtypeDeriving                       InstanceSigs                       KindSignatures                       LambdaCase                       MultiParamTypeClasses+                      NamedFieldPuns                       OverloadedStrings+                      OverloadedLists                       PolyKinds                       RankNTypes                       RecordWildCards                       ScopedTypeVariables+                      StandaloneDeriving                       TemplateHaskellQuotes                       TypeApplications                       TypeFamilies                       TypeOperators-  build-depends:      aeson                 >=1.4 && <1.6-                    , base                  >=4.12.0.0 && <5-                    , base64-bytestring     >=1.0.0.3 && <1.3-                    , bytestring            >=0.10.8.2 && <0.12-                    , bytestring-conversion ==0.3.*-                    , case-insensitive      ==1.2.*-                    , http-api-data         ==0.4.*-                    , http-types            ==0.12.*-                    , mtl                   ==2.2.*-                    , network               >=2.8 && <3.2-                    , template-haskell      >=2.14.0.0 && <3-                    , text                  ==1.2.*-                    , unordered-containers  ==0.2.*-                    , wai                   ==3.2.*+  build-depends:      base >=4.13.0.0 && <4.17+                    , base64-bytestring >=1.0.0.3 && <1.3+                    , bytestring >=0.10.10.1 && <0.12+                    , http-types ==0.12.*+                    , text ==1.2.*+                    , wai ==3.2.*+                    , webgear-core ==1.0.0   ghc-options:        -Wall                       -Wno-unticked-promoted-constructors+                      -Wcompat+                      -Widentities                       -Wincomplete-record-updates                       -Wincomplete-uni-patterns+                      -Wmissing-fields+                      -Wmissing-home-modules+                      -Wmissing-deriving-strategies+                      -Wpartial-fields                       -Wredundant-constraints+                      -fshow-warning-groups -  if impl(ghc >= 8.8.1)-    ghc-options:      -fwrite-ide-info-                      -hiedir=.hie+  if impl(ghc >= 8.10)+    ghc-options:      -Wunused-packages                        library   import:             webgear-common-  exposed-modules:    WebGear-                    , WebGear.Modifiers-                    , WebGear.Trait-                    , WebGear.Types-                    , WebGear.Middlewares-                    , WebGear.Middlewares.Auth.Basic-                    , WebGear.Middlewares.Body-                    , WebGear.Middlewares.Header-                    , WebGear.Middlewares.Method-                    , WebGear.Middlewares.Params-                    , WebGear.Middlewares.Path+  exposed-modules:    WebGear.Server+                    , WebGear.Server.Handler+                    , WebGear.Server.Traits+                    , WebGear.Server.Trait.Auth.Basic+                    , WebGear.Server.Trait.Auth.JWT+                    , WebGear.Server.Trait.Body+                    , WebGear.Server.Trait.Header+                    , WebGear.Server.Trait.Method+                    , WebGear.Server.Trait.Path+                    , WebGear.Server.Trait.QueryParam+                    , WebGear.Server.Trait.Status   other-modules:      Paths_webgear_server-                    , WebGear.Util   autogen-modules:    Paths_webgear_server   hs-source-dirs:     src+  build-depends:      aeson >=1.4 && <2.1+                    , arrows ==0.4.*+                    , bytestring-conversion ==0.3.*+                    , http-api-data ==0.4.*+                    , http-media ==0.8.*+                    , jose >=0.8.3.1 && <0.10+                    , monad-time ==0.3.*+                    , mtl ==2.2.*+                    , unordered-containers ==0.2.*  test-suite webgear-server-test   import:             webgear-common@@ -99,7 +112,7 @@                     , Properties                     , Properties.Trait.Body                     , Properties.Trait.Header-                    , Properties.Trait.Params+                    , Properties.Trait.QueryParam                     , Properties.Trait.Method                     , Properties.Trait.Path                     , Properties.Trait.Auth.Basic@@ -108,9 +121,9 @@   ghc-options:        -threaded                       -rtsopts                       -with-rtsopts=-N-  build-depends:      QuickCheck            >=2.13 && <2.15-                    , quickcheck-instances  ==0.3.*-                    , tasty                 >=1.2 && <1.5-                    , tasty-hunit           ==0.10.*-                    , tasty-quickcheck      ==0.10.*+  build-depends:      QuickCheck >=2.13 && <2.15+                    , quickcheck-instances ==0.3.*+                    , tasty >=1.2 && <1.5+                    , tasty-hunit ==0.10.*+                    , tasty-quickcheck ==0.10.*                     , webgear-server