diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/src/WebGear.hs b/src/WebGear.hs deleted file mode 100644 --- a/src/WebGear.hs +++ /dev/null @@ -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. --- diff --git a/src/WebGear/Middlewares.hs b/src/WebGear/Middlewares.hs deleted file mode 100644 --- a/src/WebGear/Middlewares.hs +++ /dev/null @@ -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 diff --git a/src/WebGear/Middlewares/Auth/Basic.hs b/src/WebGear/Middlewares/Auth/Basic.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Auth/Basic.hs +++ /dev/null @@ -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" diff --git a/src/WebGear/Middlewares/Body.hs b/src/WebGear/Middlewares/Body.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Body.hs +++ /dev/null @@ -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 diff --git a/src/WebGear/Middlewares/Header.hs b/src/WebGear/Middlewares/Header.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Header.hs +++ /dev/null @@ -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) diff --git a/src/WebGear/Middlewares/Method.hs b/src/WebGear/Middlewares/Method.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Method.hs +++ /dev/null @@ -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) diff --git a/src/WebGear/Middlewares/Params.hs b/src/WebGear/Middlewares/Params.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Params.hs +++ /dev/null @@ -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) diff --git a/src/WebGear/Middlewares/Path.hs b/src/WebGear/Middlewares/Path.hs deleted file mode 100644 --- a/src/WebGear/Middlewares/Path.hs +++ /dev/null @@ -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 ".") diff --git a/src/WebGear/Modifiers.hs b/src/WebGear/Modifiers.hs deleted file mode 100644 --- a/src/WebGear/Modifiers.hs +++ /dev/null @@ -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 diff --git a/src/WebGear/Server.hs b/src/WebGear/Server.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server.hs @@ -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 () diff --git a/src/WebGear/Server/Handler.hs b/src/WebGear/Server/Handler.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Handler.hs @@ -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) diff --git a/src/WebGear/Server/Trait/Auth/Basic.hs b/src/WebGear/Server/Trait/Auth/Basic.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Auth/Basic.hs @@ -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 diff --git a/src/WebGear/Server/Trait/Auth/JWT.hs b/src/WebGear/Server/Trait/Auth/JWT.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Auth/JWT.hs @@ -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 diff --git a/src/WebGear/Server/Trait/Body.hs b/src/WebGear/Server/Trait/Body.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Body.hs @@ -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 [] diff --git a/src/WebGear/Server/Trait/Header.hs b/src/WebGear/Server/Trait/Header.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Header.hs @@ -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 diff --git a/src/WebGear/Server/Trait/Method.hs b/src/WebGear/Server/Trait/Method.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Method.hs @@ -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{..} diff --git a/src/WebGear/Server/Trait/Path.hs b/src/WebGear/Server/Trait/Path.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Path.hs @@ -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) diff --git a/src/WebGear/Server/Trait/QueryParam.hs b/src/WebGear/Server/Trait/QueryParam.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/QueryParam.hs @@ -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 diff --git a/src/WebGear/Server/Trait/Status.hs b/src/WebGear/Server/Trait/Status.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Trait/Status.hs @@ -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 diff --git a/src/WebGear/Server/Traits.hs b/src/WebGear/Server/Traits.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Server/Traits.hs @@ -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 () diff --git a/src/WebGear/Trait.hs b/src/WebGear/Trait.hs deleted file mode 100644 --- a/src/WebGear/Trait.hs +++ /dev/null @@ -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) diff --git a/src/WebGear/Types.hs b/src/WebGear/Types.hs deleted file mode 100644 --- a/src/WebGear/Types.hs +++ /dev/null @@ -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 diff --git a/src/WebGear/Util.hs b/src/WebGear/Util.hs deleted file mode 100644 --- a/src/WebGear/Util.hs +++ /dev/null @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -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 + ] diff --git a/test/Properties/Trait/Auth/Basic.hs b/test/Properties/Trait/Auth/Basic.hs --- a/test/Properties/Trait/Auth/Basic.hs +++ b/test/Properties/Trait/Auth/Basic.hs @@ -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 [] diff --git a/test/Properties/Trait/Body.hs b/test/Properties/Trait/Body.hs --- a/test/Properties/Trait/Body.hs +++ b/test/Properties/Trait/Body.hs @@ -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 [] diff --git a/test/Properties/Trait/Header.hs b/test/Properties/Trait/Header.hs --- a/test/Properties/Trait/Header.hs +++ b/test/Properties/Trait/Header.hs @@ -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 [] diff --git a/test/Properties/Trait/Method.hs b/test/Properties/Trait/Method.hs --- a/test/Properties/Trait/Method.hs +++ b/test/Properties/Trait/Method.hs @@ -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 [] diff --git a/test/Properties/Trait/Params.hs b/test/Properties/Trait/Params.hs deleted file mode 100644 --- a/test/Properties/Trait/Params.hs +++ /dev/null @@ -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 diff --git a/test/Properties/Trait/Path.hs b/test/Properties/Trait/Path.hs --- a/test/Properties/Trait/Path.hs +++ b/test/Properties/Trait/Path.hs @@ -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 [] diff --git a/test/Properties/Trait/QueryParam.hs b/test/Properties/Trait/QueryParam.hs new file mode 100644 --- /dev/null +++ b/test/Properties/Trait/QueryParam.hs @@ -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 diff --git a/test/Unit.hs b/test/Unit.hs --- a/test/Unit.hs +++ b/test/Unit.hs @@ -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 + ] diff --git a/test/Unit/Trait/Header.hs b/test/Unit/Trait/Header.hs --- a/test/Unit/Trait/Header.hs +++ b/test/Unit/Trait/Header.hs @@ -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] diff --git a/test/Unit/Trait/Path.hs b/test/Unit/Trait/Path.hs --- a/test/Unit/Trait/Path.hs +++ b/test/Unit/Trait/Path.hs @@ -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] diff --git a/webgear-server.cabal b/webgear-server.cabal --- a/webgear-server.cabal +++ b/webgear-server.cabal @@ -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