webgear-server (empty) → 0.1.0
raw patch · 27 files changed
+1995/−0 lines, 27 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, http-api-data, http-types, mtl, quickcheck-instances, tagged, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, unordered-containers, wai, webgear-server
Files
- ChangeLog.md +14/−0
- LICENSE +373/−0
- README.md +9/−0
- src/WebGear.hs +243/−0
- src/WebGear/Middlewares.hs +46/−0
- src/WebGear/Middlewares/Body.hs +64/−0
- src/WebGear/Middlewares/Header.hs +47/−0
- src/WebGear/Middlewares/Method.hs +32/−0
- src/WebGear/Middlewares/Path.hs +115/−0
- src/WebGear/Route.hs +81/−0
- src/WebGear/Trait.hs +136/−0
- src/WebGear/Trait/Body.hs +34/−0
- src/WebGear/Trait/Header.hs +71/−0
- src/WebGear/Trait/Method.hs +68/−0
- src/WebGear/Trait/Path.hs +66/−0
- src/WebGear/Types.hs +107/−0
- src/WebGear/Util.hs +27/−0
- test/Main.hs +21/−0
- test/Properties.hs +23/−0
- test/Properties/Trait/Body.hs +53/−0
- test/Properties/Trait/Header.hs +55/−0
- test/Properties/Trait/Method.hs +38/−0
- test/Properties/Trait/Path.hs +52/−0
- test/Unit.hs +19/−0
- test/Unit/Trait/Header.hs +45/−0
- test/Unit/Trait/Path.hs +26/−0
- webgear-server.cabal +130/−0
+ ChangeLog.md view
@@ -0,0 +1,14 @@+# Changelog for webgear-server++## Unreleased changes++## [0.1.0] - 2020-08-16++### Added++- Support basic traits and middlewares+- Automated tests+- Documentation++[0.1.0]: https://github.com/rkaippully/webgear/compare/0.0.0...0.1.0+[Unreleased]: https://github.com/rkaippully/webgear/compare/0.1.0...HEAD
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,9 @@+# WebGear - HTTP API server++[](https://hackage.haskell.org/package/webgear-server)+[](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.
+ src/WebGear.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}+-- |+-- 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+ ) where++import Control.Applicative (Alternative (..))+import Control.Arrow (Kleisli (..))+import Web.HttpApiData (FromHttpApiData)++import qualified Network.Wai as Wai++import WebGear.Middlewares+import WebGear.Route+import WebGear.Trait+import WebGear.Trait.Body+import WebGear.Trait.Header+import WebGear.Trait.Method+import WebGear.Trait.Path+import WebGear.Types+++--+-- $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'+-- @+--+-- 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; the+-- 'Header' trait represents that. All traits have instances of+-- 'Trait' typeclass. This typeclass helps to 'check' the presence of+-- the trait. It also has two associated types - 'Val' and 'Fail' - to+-- represent the result of 'check'ing the presence of a trait.+--+-- For example, the 'Header' trait has an instance of the 'Trait'+-- typeclass. The 'check' function evaluates to a 'CheckSuccess' value+-- if the header exists and can be converted to an attribute via the+-- 'FromHttpApiData' typeclass. Otherwise, it evaluates to a+-- 'CheckFail' value.+--+-- WebGear provides type-safety by linking traits to the request or+-- response at type level. The 'Linked' data type associates a+-- 'Request' or 'Response' with a list of traits. This linking+-- guarantees that the Request or Response has the specified trait.+--+-- These functions work with traits and linked values:+--+-- * 'linkzero': Establish a link between a value and an empty list+-- of traits. This always succeeds.+-- * 'linkplus': Attempts to establish a link between a linked value+-- with an additional trait.+-- * 'linkminus': Removes a trait from the list of linked traits.+-- * 'unlink': Convert a linked value to a regular value without any+-- type-level traits.+-- * 'traitValue': Extract a 'Val' 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' -> m (Either 'MethodMismatch' ('Linked' '['Method' GET] 'Request'))+-- linkedRequest = 'linkplus' @('Method' GET) . 'linkzero'+-- @+--+-- Let us modify the type signature of our handler to use linked+-- values instead of regular values:+--+-- > handler :: Monad m => Linked req Request -> m (Linked res Response)+--+-- Here, @req@ is a type-level list of traits associated with the+-- @Request@ that this handler requires and @res@ is a type-level list+-- of traits associated with the @Response@ that this handler will+-- produce. This implies that this handler can be called only with a+-- request possessing certain traits and it is guaranteed to produce a+-- response having certain traits.+--+--+-- $handlers+--+-- Handlers in WebGear are defined with a type very similar to the+-- above.+--+-- @+-- type 'Handler' m req res a = 'Kleisli' m ('Linked' req 'Request') ('Linked' res ('Response' 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.+--+-- A handler can extract some trait attribute of a request with the+-- 'traitValue' function. It can also use 'linkplus' function to prove+-- the presence of traits in the response before returning it.+--+--+-- $middlewares+--+-- A middleware is a higher-order function that takes a handler as+-- input and produces another handler with potentially different lists+-- of request and response traits. Thus middlewares can augment the+-- functionality of another handler.+--+-- For example, here is the definition of the 'method' middleware:+--+-- @+-- method :: ('IsStdMethod' t, 'MonadRouter' m) => 'Handler' m ('Method' t:req) res a -> 'Handler' m req res a+-- method handler = 'Kleisli' $ 'linkplus' \@('Method' t) >=> 'either' ('const' 'rejectRoute') ('runKleisli' handler)+-- @+--+-- The @linkplus \@(Method t)@ function is used to prove the presence+-- of the method @t@ in the request and the @handler@ is invoked only+-- if the method matches. In case of a mismatch, this route is+-- rejected by calling 'rejectRoute'.+--+-- Many middlewares can be composed to form complex request handling+-- logic.+--+-- @+-- putUser = 'method' \@PUT+-- $ 'requestContentType' \@"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+-- 'failHandler' :: 'Response' ByteString -> m a+-- @+--+-- The 'failHandler' can be used in cases where we find a matching+-- route but the request handling is aborted for some reason. For+-- example, if a route requires the request Content-type header to+-- have a particular value but the actual request had a different+-- Content-type, 'failHandler' can be used to abort and return an+-- 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 :: 'MonadRouter' m => 'Handler' m '[] '[] ByteString+-- allRoutes = ['match'| v1\/users\/userId:Int |] -- non-TH version: 'path' \@"v1/users" . 'pathVar' \@"userId" \@Int+-- $ getUser \<|\> putUser \<|\> deleteUser+--+-- type IntUserId = 'PathVar' "userId" Int+--+-- getUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString+-- getUser = 'method' \@GET getUserHandler+--+-- putUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString+-- putUser = 'method' \@PUT+-- $ 'requestContentType' \@"application/json"+-- $ 'jsonRequestBody' \@User+-- $ putUserHandler+--+-- deleteUser :: ('MonadRouter' m, 'Has' IntUserId req) => 'Handler' m req '[] ByteString+-- deleteUser = 'method' \@DELETE deleteUserHandler+-- @+--+--+-- $running+--+-- Routable handlers can be converted to a regular function using+-- 'runRoute':+--+-- @+-- runRoute :: Monad m => 'Handler' (RouterT m) '[] res ByteString -> ('Wai.Request' -> m 'Wai.Response')+-- @+--+-- This function converts a WebGear handler to a function from+-- 'Wai.Request' to 'Wai.Response' in a monadic context @m@. Then it+-- is trivial to convert that to a WAI 'Wai.Application' and run it as a+-- warp server:+--+-- @+-- application :: 'Wai.Application'+-- application req respond = 'runRoute' allRoutes req >>= respond+--+-- main :: IO ()+-- main = Warp.run 3000 application+-- @+--
+ src/WebGear/Middlewares.hs view
@@ -0,0 +1,46 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Middlewares provided by WebGear.+--+module WebGear.Middlewares+ ( ok+ , noContent+ , badRequest+ , notFound++ , module WebGear.Middlewares.Method+ , module WebGear.Middlewares.Path+ , module WebGear.Middlewares.Header+ , module WebGear.Middlewares.Body+ ) where++import Data.String (IsString)++import WebGear.Middlewares.Body+import WebGear.Middlewares.Header+import WebGear.Middlewares.Method+import WebGear.Middlewares.Path+import WebGear.Trait (Linked, linkzero)+import WebGear.Types (Response (..))++import qualified Network.HTTP.Types as HTTP+++-- | Respond with a 200 OK+ok :: Monad m => a -> m (Linked '[] (Response a))+ok = pure . linkzero . Response HTTP.ok200 mempty . Just++-- | Respond with a 400 Bad Request+badRequest :: Monad m => m (Linked '[] (Response a))+badRequest = pure $ linkzero $ Response HTTP.badRequest400 mempty Nothing++-- | Respond with a 404 NotFound+notFound :: Monad m => m (Linked '[] (Response a))+notFound = pure $ linkzero $ Response HTTP.notFound404 mempty Nothing++-- | Respond with a 204 NoContent+noContent :: (Monad m, IsString s) => m (Linked '[] (Response s))+noContent = pure $ linkzero $ Response HTTP.noContent204 mempty $ Just ""
+ src/WebGear/Middlewares/Body.hs view
@@ -0,0 +1,64 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Middlewares related to HTTP body.+module WebGear.Middlewares.Body+ ( jsonRequestBody+ , jsonResponseBody+ ) where++import Control.Arrow (Kleisli (..))+import Control.Monad ((>=>))+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson (FromJSON, ToJSON, encode)+import Data.ByteString.Lazy (ByteString, fromStrict)+import Data.HashMap.Strict (fromList, insert)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Types (badRequest400, hContentType)++import WebGear.Route (MonadRouter (..))+import WebGear.Trait (linkplus, linkzero, unlink)+import WebGear.Trait.Body (JSONRequestBody)+import WebGear.Types (Middleware, RequestMiddleware, Response (..))+++-- | 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+--+jsonRequestBody :: forall t m req res a. (FromJSON t, MonadRouter m, MonadIO m)+ => RequestMiddleware m req (JSONRequestBody t:req) res a+jsonRequestBody handler = Kleisli $+ linkplus @(JSONRequestBody t) >=> either (failHandler . mkError) (runKleisli handler)+ where+ mkError :: Text -> Response ByteString+ mkError e = Response+ { respStatus = badRequest400+ , respHeaders = fromList []+ , respBody = Just $ 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) => Middleware m req req res '[] t ByteString+jsonResponseBody handler = Kleisli $ \req -> do+ x <- unlink <$> runKleisli handler req+ pure $ linkzero $ Response+ { respStatus = respStatus x+ , respHeaders = insert hContentType "application/json" $ respHeaders x+ , respBody = encode <$> respBody x+ }
+ src/WebGear/Middlewares/Header.hs view
@@ -0,0 +1,47 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Middlewares related to HTTP headers.+module WebGear.Middlewares.Header+ ( requestContentType+ ) where++import Control.Arrow (Kleisli (..))+import Control.Monad ((>=>))+import Data.ByteString.Lazy (ByteString)+import Data.HashMap.Strict (fromList)+import Data.String (fromString)+import GHC.TypeLits (KnownSymbol)+import Network.HTTP.Types (badRequest400)+import Text.Printf (printf)++import WebGear.Route (MonadRouter (..))+import WebGear.Trait (linkplus)+import WebGear.Trait.Header (HeaderMatch, HeaderMismatch (..))+import WebGear.Types (RequestMiddleware, Response (..))+++-- | A middleware to check that the Content-Type header in the request+-- has a specific value. It will fail the handler if the header did+-- not match.+--+-- Typical usage:+--+-- > requestContentType @"application/json" handler+--+requestContentType :: forall c m req res a. (KnownSymbol c, MonadRouter m)+ => RequestMiddleware m req (HeaderMatch "Content-Type" c:req) res a+requestContentType handler = Kleisli $+ linkplus @(HeaderMatch "Content-Type" c) >=> either (failHandler . mkError) (runKleisli handler)+ where+ mkError :: HeaderMismatch -> Response ByteString+ mkError err = Response+ { respStatus = badRequest400+ , respHeaders = fromList []+ , respBody = Just $ fromString $+ case (expectedHeader err, actualHeader err) of+ (ex, Nothing) -> printf "Expected Content-Type header %s but not found" (show ex)+ (ex, Just h) -> printf "Expected Content-Type header %s but found %s" (show ex) (show h)+ }
+ src/WebGear/Middlewares/Method.hs view
@@ -0,0 +1,32 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Middlewares related to HTTP methods.+module WebGear.Middlewares.Method+ ( method+ ) where++import Control.Arrow (Kleisli (..))+import Control.Monad ((>=>))++import WebGear.Route (MonadRouter (..))+import WebGear.Trait (linkplus)+import WebGear.Trait.Method (IsStdMethod, Method)+import WebGear.Types (RequestMiddleware)+++-- | 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 res a. (IsStdMethod t, MonadRouter m)+ => RequestMiddleware m req (Method t:req) res a+method handler = Kleisli $ linkplus @(Method t) >=> either (const rejectRoute) (runKleisli handler)
+ src/WebGear/Middlewares/Path.hs view
@@ -0,0 +1,115 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Middlewares related to route paths.+module WebGear.Middlewares.Path+ ( path+ , pathVar+ , match+ ) where++import Control.Arrow (Kleisli (..))+import Control.Monad ((>=>))+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty (..), toList)+import GHC.TypeLits (KnownSymbol)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName)+import Web.HttpApiData (FromHttpApiData)++import WebGear.Middlewares.Method (method)+import WebGear.Route (MonadRouter (..))+import WebGear.Trait (linkplus)+import WebGear.Trait.Path (Path, PathVar)+import WebGear.Types (RequestMiddleware)+import WebGear.Util (splitOn)++import qualified Data.List as List+++-- | 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 res m a. (KnownSymbol s, MonadRouter m)+ => RequestMiddleware m ts (Path s:ts) res a+path handler = Kleisli $+ linkplus @(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 res m a. (FromHttpApiData val, MonadRouter m)+ => RequestMiddleware m ts (PathVar tag val:ts) res a+pathVar handler = Kleisli $+ linkplus @(PathVar tag val) >=> either (const rejectRoute) (runKleisli handler)++-- | Produces middleware(s) to match an optional HTTP method and path.+--+-- This quasiquoter can be used in several ways:+--+-- * @[match|a\/b\/c]@ is equivalent to @'path' \@\"a\/b\/c\"@+-- * @[match|a\/b\/objId:Int\/d]@ is equivalent to+-- @'path' \@\"a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' @\"d\"@+-- * @[match|GET a\/b\/c]@ is equivalent to+-- @'method' \@GET $ 'path' \@\"a\/b\/c\"@+-- * @[match|GET a\/b\/objId:Int\/d]@ is equivalent to+-- @'method' \@GET . 'path' \@\"a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@+--+match :: QuasiQuoter+match = QuasiQuoter+ { quoteExp = toExp+ , quotePat = const $ fail "match cannot be used in a pattern"+ , quoteType = const $ fail "match cannot be used in a type"+ , quoteDec = const $ fail "match cannot be used in a declaration"+ }+ where+ toExp :: String -> Q Exp+ toExp s = case List.words s of+ [m, p] -> do+ let methodExp = AppTypeE (VarE 'method) (ConT $ mkName m)+ pathExps <- toPathExps p+ pure $ List.foldr1 compose $ methodExp :| pathExps+ [p] -> do+ pathExps <- toPathExps p+ pure $ List.foldr1 compose pathExps+ _ -> fail "match expects an HTTP method and a path or just a path"++ toPathExps :: String -> Q [Exp]+ toPathExps p = splitOn '/' p+ & fmap (splitOn ':')+ & List.foldr joinPath []+ & fmap toPathExp+ & sequence++ joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]+ joinPath s [] = [s]+ joinPath (s:|[]) ((s':|[]) : xs) = ((s <> "/" <> s') :| []) : xs+ joinPath y (x:xs) = y:x:xs++ toPathExp :: NonEmpty String -> Q Exp+ toPathExp (p :| []) = pure $ AppTypeE (VarE 'path) (LitT $ StrTyLit p)+ toPathExp (v :| [t]) = pure $ AppTypeE (AppTypeE (VarE 'pathVar) (LitT $ StrTyLit v)) (ConT $ mkName t)+ toPathExp xs = fail $ "Invalid path component: " <> List.intercalate ":" (toList xs)++ compose :: Exp -> Exp -> Exp+ compose l = UInfixE l (VarE $ mkName ".")
+ src/WebGear/Route.hs view
@@ -0,0 +1,81 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Types and functions to route HTTP requests.+module WebGear.Route+ ( RouterT+ , MonadRouter (..)+ , runRoute+ ) where++import Control.Applicative (Alternative)+import Control.Arrow (Kleisli (..))+import Control.Monad (MonadPlus (..))+import Control.Monad.Except (ExceptT, MonadError (..), runExceptT)+import Data.ByteString.Lazy (ByteString)+import Data.HashMap.Strict (fromList)+import Data.Semigroup (First (..))+import Data.String (fromString)+import Data.Version (showVersion)+import Network.HTTP.Types (Header, hServer, notFound404)++import Paths_webgear_server (version)+import WebGear.Trait (linkzero, unlink)+import WebGear.Types (Handler, Response (..), waiResponse)++import qualified Network.Wai as Wai+++-- | The monad transformer stack for routing.+--+-- * The 'ExceptT' provides short-circuiting behaviour for+-- 'rejectRoute' and 'failHandler'.+--+-- * In case of 'rejectRoute', a 'Nothing' value is returned and in+-- case of 'failHandler', a @Response ByteString@ is returned.+--+-- * The 'First' wrapper is provided to get instances of 'Alternative'+-- and 'MonadPlus' for 'RouterT'.+--+type RouterT m = ExceptT (Maybe (First (Response ByteString))) m++-- | HTTP request routing with short circuiting behavior.+class (Alternative m, MonadPlus m) => MonadRouter m where+ -- | Mark the current route as rejected, alternatives can be tried+ rejectRoute :: m a++ -- | Short-circuit the current handler and return a response+ failHandler :: Response ByteString -> m a++instance Monad m => MonadRouter (RouterT m) where+ rejectRoute :: RouterT m a+ rejectRoute = mzero++ failHandler :: Response ByteString -> RouterT m a+ failHandler = throwError . Just . First++-- | Convert a routable handler into a plain function.+--+-- This function is typically used to convert WebGear routes to a+-- 'Wai.Application'.+runRoute :: Monad m+ => Handler (RouterT m) '[] res ByteString+ -> (Wai.Request -> m Wai.Response)+runRoute route req = waiResponse . addServerHeader . either (maybe notFoundResponse getFirst) id <$> runExceptT f+ where+ f = unlink <$> runKleisli route (linkzero req)++ notFoundResponse :: Response ByteString+ notFoundResponse = Response+ { respStatus = notFound404+ , respHeaders = fromList []+ , respBody = Just "Not Found"+ }++ addServerHeader :: Response ByteString -> Response ByteString+ addServerHeader r = r { respHeaders = respHeaders r <> fromList [serverHeader] }++ serverHeader :: Header+ serverHeader = (hServer, fromString $ "WebGear/" ++ showVersion version)
+ src/WebGear/Trait.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Traits are optional attributes that a value might posess. For example,+-- a list containing totally ordered values might have a @Maximum@ trait+-- where the associated attribute is the maximum value. The trait exists+-- only if the list is non-empty.+--+-- Traits help to access these attributes 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 (..)+ , CheckResult (..)+ , Linked+ , Traits++ -- * Linking values with traits+ , linkzero+ , linkplus+ , linkminus+ , unlink++ -- * Retrive trait attributes from linked values+ , Has (..)+ , Have+ ) where++import Data.Kind (Constraint, Type)+import Data.Tagged (Tagged (..))+++-- | A 'Trait' is an optional attribute @t@ associated with a value @a@.+--+-- The 'check' function validates the presence of the trait for a+-- given value. Checking the presence of the trait can optionally+-- modify the value as well.+class Monad m => Trait t a m where+ -- | Type of the associated attribute+ type Val t a++ -- | Type of check failures+ type Fail t a++ -- | Checks the presence of the associated attribute.+ check :: a -> m (CheckResult t a)++-- | Result of a 'check' operation+data CheckResult t a = CheckSuccess a (Val t a)+ | CheckFail (Fail t a)++deriving instance (Eq a, Eq (Val t a), Eq (Fail t a)) => Eq (CheckResult t a)+deriving instance (Show a, Show (Val t a), Show (Fail t a)) => Show (CheckResult t a)+deriving instance (Read a, Read (Val t a), Read (Fail t a)) => Read (CheckResult t a)+++-- | A trivial trait that is always present and whose attribute does+-- not carry any meaningful information.+instance Monad m => Trait '[] a m where+ type Val '[] a = ()+ type Fail '[] a = ()++ check :: a -> m (CheckResult '[] a)+ check a = pure $ CheckSuccess a ()++-- | Combination of many traits all of which are present for a value.+instance (Trait t a m, Trait ts a m) => Trait (t:ts) a m where+ type Val (t:ts) a = (Val t a, Val ts a)+ type Fail (t:ts) a = Either (CheckResult t a) (CheckResult ts a)++ check :: a -> m (CheckResult (t:ts) a)+ check a = check @t a >>= \case+ e@(CheckFail _) -> pure $ CheckFail $ Left e+ CheckSuccess a' l -> check @ts a' >>= \case+ e@(CheckFail _) -> pure $ CheckFail $ Right e+ CheckSuccess a'' r -> pure $ CheckSuccess a'' (l, r)++-- | Constraint for functions that use multiple traits+type family Traits ts a m :: Constraint where+ Traits '[] a m = ()+ Traits (t:ts) a m = (Trait t a m, Traits ts a m)++-- | A value linked with a type-level list of traits.+data Linked (ts :: [Type]) a = Linked+ { linkVal :: !(Val ts a)+ , unlink :: !a -- ^ Retrive the value from a linked value+ }++-- | Link a value with the trivial trait+linkzero :: a -> Linked '[] a+linkzero = Linked ()++-- | Attempt to link an additional trait with an already linked value+linkplus :: Trait t a m => Linked ts a -> m (Either (Fail t a) (Linked (t:ts) a))+linkplus l = do+ v <- check (unlink l)+ pure $ mkLinked v l+ where+ mkLinked :: CheckResult t a -> Linked ts a -> Either (Fail t a) (Linked (t:ts) a)+ mkLinked (CheckSuccess a left) lv = Right $ Linked (left, linkVal lv) a+ mkLinked (CheckFail e) _ = Left e++-- | Remove the leading trait from the linked value+linkminus :: Linked (t:ts) a -> Linked ts a+linkminus l = Linked (snd $ linkVal l) (unlink l)+++-- | Constraint that proves that the trait @t@ is present somewhere in+-- the list of traits @ts@.+class Has t ts where+ traitValue :: Linked ts a -> Tagged t (Val t a)++instance Has t (t:ts) where+ traitValue :: Linked (t : ts) a -> Tagged t (Val t a)+ traitValue (Linked (lv, _) _) = Tagged lv++instance {-# OVERLAPPABLE #-} Has t ts => Has t (t':ts) where+ traitValue :: Linked (t':ts) a -> Tagged t (Val t a)+ traitValue l = traitValue (rightLinked l)+ where+ rightLinked :: Linked (q:qs) b -> Linked qs b+ rightLinked (Linked (_, rv) a) = Linked rv a+++-- | Constraint that proves that all the traits in the list @ts@ are+-- present in the list @qs@.+type family Have ts qs :: Constraint where+ Have '[] qs = ()+ Have (t:ts) qs = (Has t qs, Have ts qs)
+ src/WebGear/Trait/Body.hs view
@@ -0,0 +1,34 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Traits related to HTTP body.+module WebGear.Trait.Body+ ( JSONRequestBody+ ) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson (FromJSON, eitherDecode')+import Data.ByteString.Lazy (fromChunks)+import Data.Kind (Type)+import Data.Text (Text, pack)++import WebGear.Trait (CheckResult (..), Trait (..))+import WebGear.Types (Request, getRequestBodyChunk)+import WebGear.Util (takeWhileM)+++-- | A 'Trait' for converting a JSON request body into a value.+data JSONRequestBody (t :: Type)++instance (FromJSON t, MonadIO m) => Trait (JSONRequestBody t) Request m where+ type Val (JSONRequestBody t) Request = t+ type Fail (JSONRequestBody t) Request = Text++ check :: Request -> m (CheckResult (JSONRequestBody t) Request)+ check r = do+ chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk r+ pure $ case eitherDecode' (fromChunks chunks) of+ Left e -> CheckFail (pack e)+ Right t -> CheckSuccess r t
+ src/WebGear/Trait/Header.hs view
@@ -0,0 +1,71 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Traits related to HTTP headers.+module WebGear.Trait.Header+ ( Header+ , HeaderFail (..)+ , HeaderMatch+ , HeaderMismatch (..)+ ) where++import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.String (fromString)+import Data.Text (Text)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Web.HttpApiData (FromHttpApiData (..))++import WebGear.Trait (CheckResult (..), Trait (..))+import WebGear.Types (Request, requestHeader)+++-- | A 'Trait' for capturing a header with name @s@ in a request or+-- response and convert it to some type @t@ via 'FromHttpApiData'.+data Header (s :: Symbol) (t :: Type)++-- | Failure in extracting a header value+data HeaderFail = HeaderNotFound | HeaderParseError Text+ deriving stock (Read, Show, Eq)++instance (KnownSymbol s, FromHttpApiData t, Monad m) => Trait (Header s t) Request m where+ type Val (Header s t) Request = t+ type Fail (Header s t) Request = HeaderFail++ check :: Request -> m (CheckResult (Header s t) Request)+ check r = pure $+ let s = fromString $ symbolVal (Proxy @s)+ in case parseHeader <$> requestHeader s r of+ Nothing -> CheckFail HeaderNotFound+ Just (Left e) -> CheckFail $ HeaderParseError e+ Just (Right x) -> CheckSuccess r x++-- | A 'Trait' for ensuring that a header named @s@ has value @t@.+data HeaderMatch (s :: Symbol) (t :: Symbol)++-- | Failure in extracting a header value+data HeaderMismatch = HeaderMismatch+ { expectedHeader :: ByteString+ , actualHeader :: Maybe ByteString+ }+ deriving stock (Eq, Read, Show)++instance (KnownSymbol s, KnownSymbol t, Monad m) => Trait (HeaderMatch s t) Request m where+ type Val (HeaderMatch s t) Request = ByteString+ type Fail (HeaderMatch s t) Request = HeaderMismatch++ check :: Request -> m (CheckResult (HeaderMatch s t) Request)+ check r = pure $+ let+ name = fromString $ symbolVal (Proxy @s)+ expected = fromString $ symbolVal (Proxy @t)+ in+ case requestHeader name r of+ Nothing -> CheckFail HeaderMismatch+ {expectedHeader = expected, actualHeader = Nothing}+ Just hv | hv == expected -> CheckSuccess r hv+ | otherwise -> CheckFail HeaderMismatch+ {expectedHeader = expected, actualHeader = Just hv}
+ src/WebGear/Trait/Method.hs view
@@ -0,0 +1,68 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Trait capturing the HTTP method in a request.+module WebGear.Trait.Method+ ( Method+ , IsStdMethod (..)+ , MethodMismatch (..)+ ) where++import Data.Proxy (Proxy (..))++import WebGear.Trait (CheckResult (..), Trait (..))+import WebGear.Types (Request, requestMethod)++import qualified Network.HTTP.Types as HTTP+++-- | A 'Trait' for capturing the HTTP method of a request+data Method (t :: HTTP.StdMethod)++-- | Failure to match method against an expected value+data MethodMismatch = MethodMismatch+ { expectedMethod :: HTTP.Method+ , actualMethod :: HTTP.Method+ }++instance (Monad m, IsStdMethod t) => Trait (Method t) Request m where+ type Val (Method t) Request = HTTP.Method+ type Fail (Method t) Request = MethodMismatch++ check :: Request -> m (CheckResult (Method t) Request)+ check r =+ let+ expected = HTTP.renderStdMethod $ toStdMethod $ Proxy @t+ actual = requestMethod r+ in+ pure $ if expected == actual+ then CheckSuccess r actual+ else CheckFail $ MethodMismatch expected actual+++-- | A typeclass implemented by all 'HTTP.StdMethod's to convert them+-- from type level to term level.+class IsStdMethod t where+ -- | Convert @t@ to term level.+ toStdMethod :: Proxy t -> HTTP.StdMethod++instance IsStdMethod HTTP.GET where+ toStdMethod = const HTTP.GET+instance IsStdMethod HTTP.POST where+ toStdMethod = const HTTP.POST+instance IsStdMethod HTTP.HEAD where+ toStdMethod = const HTTP.HEAD+instance IsStdMethod HTTP.PUT where+ toStdMethod = const HTTP.PUT+instance IsStdMethod HTTP.DELETE where+ toStdMethod = const HTTP.DELETE+instance IsStdMethod HTTP.TRACE where+ toStdMethod = const HTTP.TRACE+instance IsStdMethod HTTP.CONNECT where+ toStdMethod = const HTTP.CONNECT+instance IsStdMethod HTTP.OPTIONS where+ toStdMethod = const HTTP.OPTIONS+instance IsStdMethod HTTP.PATCH where+ toStdMethod = const HTTP.PATCH
+ src/WebGear/Trait/Path.hs view
@@ -0,0 +1,66 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Traits related to the route path of a request.+module WebGear.Trait.Path+ ( Path+ , PathVar+ , PathVarFail (..)+ ) where++import Data.Kind (Type)+import Data.List (stripPrefix)+import Data.List.NonEmpty (toList)+import Data.Proxy (Proxy (..))+import Data.Text (Text, pack)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Web.HttpApiData (FromHttpApiData (..))++import WebGear.Trait (CheckResult (..), Trait (..))+import WebGear.Types (Request, pathInfo, setPathInfo)+import WebGear.Util (splitOn)+++-- | A path component which is literally matched against the request+-- but discarded after that.+data Path (s :: Symbol)++instance (KnownSymbol s, Monad m) => Trait (Path s) Request m where+ type Val (Path s) Request = ()++ -- | The path that could not be matched+ type Fail (Path s) Request = ()++ check :: Request -> m (CheckResult (Path s) Request)+ check r = pure $+ let expected = map pack $ toList $ splitOn '/' $ symbolVal $ Proxy @s+ actual = pathInfo r+ in+ case stripPrefix expected actual of+ Nothing -> CheckFail ()+ Just rest -> CheckSuccess (setPathInfo rest r) ()+++-- | A path variable that is extracted and converted to a value of+-- type @val@. The @tag@ is usually a type-level symbol (string) to+-- uniquely identify this variable.+data PathVar tag (val :: Type)++-- | Failure to extract a 'PathVar'+data PathVarFail = PathVarNotFound | PathVarParseError Text+ deriving (Eq, Show, Read)++instance (FromHttpApiData val, Monad m) => Trait (PathVar tag val) Request m where+ type Val (PathVar tag val) Request = val+ type Fail (PathVar tag val) Request = PathVarFail++ check :: Request -> m (CheckResult (PathVar tag val) Request)+ check r = pure $+ case pathInfo r of+ [] -> CheckFail PathVarNotFound+ (x:xs) ->+ case parseUrlPiece @val x of+ Left e -> CheckFail $ PathVarParseError e+ Right h -> CheckSuccess (setPathInfo xs r) h
+ src/WebGear/Types.hs view
@@ -0,0 +1,107 @@+-- |+-- 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+ -- | WebGear requests are WAI requests. This module reexports a number+ -- of useful functions that operate on requests from "Network.Wai"+ -- module.+ Request+ , remoteHost+ , httpVersion+ , isSecure+ , requestMethod+ , pathInfo+ , setPathInfo+ , queryString+ , requestHeaders+ , requestHeader+ , requestBodyLength+ , getRequestBodyChunk++ -- * WebGear Response+ , Response (..)+ , waiResponse+ , addResponseHeader++ , Handler+ , Middleware+ , RequestMiddleware+ , ResponseMiddleware+ ) where++import Control.Arrow (Kleisli)+import Data.ByteString (ByteString)+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Network.HTTP.Types (Header, HeaderName, Status)+import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString,+ remoteHost, requestBodyLength, requestHeaders, requestMethod)++import WebGear.Trait (Linked)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as HM+import qualified Network.Wai as Wai+++-- | Get the value of a request header+requestHeader :: HeaderName -> Request -> Maybe ByteString+requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r)++-- | Get request with an updated URL path info.+setPathInfo :: [Text] -> Request -> Request+setPathInfo p r = r { pathInfo = p }++-- | A response sent from the server to the client.+--+-- The response contains a status, optional headers and an optional+-- body of type @a@.+data Response a = Response+ { respStatus :: Status -- ^ Response status code+ , respHeaders :: HM.HashMap HeaderName ByteString -- ^ Response headers+ , respBody :: Maybe a -- ^ Optional response body+ }++-- | Convert a WebGear response to a WAI Response.+waiResponse :: Response LBS.ByteString -> Wai.Response+waiResponse Response{..} = Wai.responseLBS respStatus (HM.toList respHeaders) (fromMaybe "" respBody)++-- | Create or update a response header.+addResponseHeader :: Header -> Response a -> Response a+addResponseHeader (name, val) resp = resp { respHeaders = HM.insertWith f name val (respHeaders resp) }+ where+ f = flip const++-- | A handler is a function from a request to response in a monadic+-- context. Both the request and the response can have linked traits.+--+-- The type level list @req@ contains all the traits expected to be+-- present in the request. The handler will produce a response that+-- satisfies all the traits in the type level list @res@.+type Handler m req res a = Kleisli m (Linked req Request) (Linked res (Response a))++-- | 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.+-- * Change the response traits before passing it back to its caller.+-- * Use the linked value of any of the request or response traits.+-- * Change the response body.+--+type Middleware m req req' res' res a' a = Handler m req' res' a' -> Handler m req res a++-- | A middleware that manipulates only the request traits and leaves+-- the response unchanged.+type RequestMiddleware m req req' res a = Middleware m req req' res res a a++-- | A middleware that manipulates only the response traits and leaves+-- the request unchanged.+type ResponseMiddleware m req res' res a = Middleware m req req res' res a a
+ src/WebGear/Util.hs view
@@ -0,0 +1,27 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+-- Common utility functions.+module WebGear.Util+ ( takeWhileM+ , splitOn+ ) 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
+ test/Main.hs view
@@ -0,0 +1,21 @@+-- |+-- 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++allTests :: TestTree+allTests = testGroup "Tests" [unitTests, propertyTests, systemTests]++systemTests :: TestTree+systemTests = testGroup "System Tests" []
+ test/Properties.hs view
@@ -0,0 +1,23 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+module Properties+ ( propertyTests+ ) where++import Test.Tasty (TestTree, testGroup)++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.Path as Path+++propertyTests :: TestTree+propertyTests = testGroup "Property Tests" [ Body.tests+ , Header.tests+ , Method.tests+ , Path.tests+ ]
+ test/Properties/Trait/Body.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -Wno-deprecations #-}++module Properties.Trait.Body+ ( tests+ ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.String (fromString)+import Network.Wai (Request, defaultRequest, requestBody)+import Test.QuickCheck (Property, allProperties, counterexample, property)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (assert, monadicIO, monitor)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperties)++import WebGear.Trait+import WebGear.Trait.Body+++bodyToRequest :: (MonadIO m, Show a) => a -> m 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 }++prop_emptyRequestBodyFails :: Property+prop_emptyRequestBodyFails = monadicIO $ do+ req <- bodyToRequest ("" :: String)+ check @(JSONRequestBody Int) req >>= \case+ CheckSuccess _ _ -> monitor (counterexample "Unexpected success") >> assert False+ CheckFail _ -> assert True++prop_validBodyParses :: Property+prop_validBodyParses = property $ \n -> monadicIO $ do+ req <- bodyToRequest (n :: Integer)+ check @(JSONRequestBody Integer) req >>= \case+ CheckSuccess _ n' -> assert (n == n')+ CheckFail _ -> assert False++prop_invalidBodyFails :: Property+prop_invalidBodyFails = property $ \n -> monadicIO $ do+ req <- bodyToRequest (n :: Integer)+ check @(JSONRequestBody String) req >>= \case+ CheckSuccess _ _ -> assert False+ CheckFail _ -> assert True+++-- Hack for TH splicing+return []++tests :: TestTree+tests = testProperties "Trait.Body" $allProperties
+ test/Properties/Trait/Header.hs view
@@ -0,0 +1,55 @@+module Properties.Trait.Header+ ( tests+ ) where++import Data.Functor.Identity (runIdentity)+import Data.String (fromString)+import Data.Text.Encoding (encodeUtf8)+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.Trait+import WebGear.Trait.Header+++prop_headerParseError :: Property+prop_headerParseError = property $ \hval ->+ let+ hval' = "test-" <> hval+ req = defaultRequest { requestHeaders = [("foo", encodeUtf8 hval')] }+ in+ case runIdentity (check @(Header "foo" Int) req) of+ CheckFail e ->+ e === HeaderParseError ("could not parse: `" <> hval' <> "' (input does not start with a digit)")+ CheckSuccess _ v ->+ 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 (check @(Header "foo" Int) req) of+ CheckFail e ->+ counterexample ("Unexpected result: " <> show e) (property False)+ CheckSuccess _ n' -> n === n'++prop_headerMatch :: Property+prop_headerMatch = property $ \v ->+ let+ req = defaultRequest { requestHeaders = [("foo", v)] }+ in+ case runIdentity (check @(HeaderMatch "foo" "bar") req) of+ CheckFail e ->+ expectedHeader e === "bar" .&&. actualHeader e =/= Nothing .&&. actualHeader e =/= Just "bar"+ CheckSuccess _ v' -> v === "bar" .&&. v === v'+++-- Hack for TH splicing+return []++tests :: TestTree+tests = testProperties "Trait.Header" $allProperties
+ test/Properties/Trait/Method.hs view
@@ -0,0 +1,38 @@+module Properties.Trait.Method+ ( tests+ ) where++import Data.Functor.Identity (runIdentity)+import Network.HTTP.Types (StdMethod (..), methodGet, renderStdMethod)+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.Trait+import WebGear.Trait.Method+++newtype MethodWrapper = MethodWrapper StdMethod+ deriving stock (Show)++instance Arbitrary MethodWrapper where+ arbitrary = elements $ MethodWrapper <$> [minBound..maxBound]++prop_methodMatch :: Property+prop_methodMatch = property $ \(MethodWrapper v) ->+ let+ req = defaultRequest { requestMethod = renderStdMethod v }+ in+ case runIdentity (check @(Method GET) req) of+ CheckSuccess _ v' -> v === GET .&&. v' === methodGet+ CheckFail e ->+ expectedMethod e === methodGet .&&. actualMethod e =/= methodGet+++-- Hack for TH splicing+return []++tests :: TestTree+tests = testProperties "Trait.Method" $allProperties
+ test/Properties/Trait/Path.hs view
@@ -0,0 +1,52 @@+module Properties.Trait.Path+ ( tests+ ) where++import Data.Functor.Identity (runIdentity)+import Data.String (fromString)+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.Trait+import WebGear.Trait.Path+++prop_pathMatch :: Property+prop_pathMatch = property $ \h ->+ let+ rest = ["foo", "bar"]+ req = defaultRequest { pathInfo = h:rest }+ in+ case runIdentity (check @(Path "a") req) of+ CheckSuccess req' _ -> h === "a" .&&. pathInfo req' === rest+ CheckFail _ -> h =/= "a"++prop_pathVarMatch :: Property+prop_pathVarMatch = property $ \(n :: Int) ->+ let+ rest = ["foo", "bar"]+ req = defaultRequest { pathInfo = fromString (show n):rest }+ in+ case runIdentity (check @(PathVar "tag" Int) req) of+ CheckSuccess req' n' -> n' === n .&&. pathInfo req' === rest+ CheckFail _ -> property False++prop_pathVarParseError :: Property+prop_pathVarParseError = property $ \(p, ps) ->+ let+ p' = "test-" <> p+ req = defaultRequest { pathInfo = p':ps }+ in+ case runIdentity (check @(PathVar "tag" Int) req) of+ CheckSuccess _ _ -> property False+ CheckFail e -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)")+++-- Hack for TH splicing+return []++tests :: TestTree+tests = testProperties "Trait.Path" $allProperties
+ test/Unit.hs view
@@ -0,0 +1,19 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+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+ ]
+ test/Unit/Trait/Header.hs view
@@ -0,0 +1,45 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+module Unit.Trait.Header+ ( tests+ ) where++import Network.Wai (defaultRequest, requestHeaders)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++import WebGear.Trait+import WebGear.Trait.Header+++testMissingHeaderFails :: TestTree+testMissingHeaderFails = testCase "Missing header fails Header trait" $ do+ let req = defaultRequest { requestHeaders = [] }+ check @(Header "foo" Int) req >>= \case+ CheckSuccess _ _ -> assertFailure "unexpected success"+ CheckFail e -> e @?= HeaderNotFound++testHeaderMatchPositive :: TestTree+testHeaderMatchPositive = testCase "Header match: positive" $ do+ let req = defaultRequest { requestHeaders = [("foo", "bar")] }+ check @(HeaderMatch "foo" "bar") req >>= \case+ CheckSuccess _ v -> v @?= "bar"+ CheckFail e -> assertFailure $ "Unexpected result: " <> show e++testHeaderMatchMissingHeader :: TestTree+testHeaderMatchMissingHeader = testCase "Header match: missing header" $ do+ let req = defaultRequest { requestHeaders = [] }+ check @(HeaderMatch "foo" "bar") req >>= \case+ CheckSuccess _ _ -> assertFailure "unexpected success"+ CheckFail e -> e @?= HeaderMismatch { expectedHeader = "bar"+ , actualHeader = Nothing+ }++tests :: TestTree+tests = testGroup "Trait.Header" [ testMissingHeaderFails+ , testHeaderMatchPositive+ , testHeaderMatchMissingHeader+ ]
+ test/Unit/Trait/Path.hs view
@@ -0,0 +1,26 @@+-- |+-- Copyright : (c) Raghu Kaippully, 2020+-- License : MPL-2.0+-- Maintainer : rkaippully@gmail.com+--+module Unit.Trait.Path+ ( tests+ ) where++import Network.Wai (defaultRequest, pathInfo)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++import WebGear.Trait+import WebGear.Trait.Path+++testMissingPathVar :: TestTree+testMissingPathVar = testCase "PathVar match: missing variable" $ do+ let req = defaultRequest { pathInfo = [] }+ check @(PathVar "tag" Int) req >>= \case+ CheckSuccess _ _ -> assertFailure "unexpected success"+ CheckFail e -> e @?= PathVarNotFound++tests :: TestTree+tests = testGroup "Trait.Path" [ testMissingPathVar ]
+ webgear-server.cabal view
@@ -0,0 +1,130 @@+cabal-version: 2.4+name: webgear-server+version: 0.1.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+author: Raghu Kaippully+maintainer: rkaippully@gmail.com+copyright: 2020 Raghu Kaippully+license: MPL-2.0+license-file: LICENSE+category: Web+build-type: Simple+extra-source-files: README.md+ ChangeLog.md+++source-repository head+ type: git+ location: https://github.com/rkaippully/webgear+++common webgear-common+ default-language: Haskell2010+ default-extensions: ApplicativeDo+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ EmptyCase+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ PatternSynonyms+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeFamilyDependencies+ TypeOperators+ build-depends: base >=4.13.0.0 && <5+ , template-haskell >=2.15.0.0 && <3+ , mtl ==2.2.*+ , unordered-containers ==0.2.*+ , wai ==3.2.*+ , bytestring ==0.10.*+ , text ==1.2.*+ , http-types ==0.12.*+ , http-api-data ==0.4.*+ , aeson ==1.4.*+ , tagged ==0.8.*+ ghc-options: -fwrite-ide-info+ -hiedir=.hie+ -Wall+ -Wno-unticked-promoted-constructors+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++library+ import: webgear-common+ exposed-modules: WebGear+ , WebGear.Trait+ , WebGear.Trait.Method+ , WebGear.Trait.Header+ , WebGear.Trait.Path+ , WebGear.Trait.Body+ , WebGear.Types+ , WebGear.Route+ , WebGear.Middlewares+ , WebGear.Middlewares.Body+ , WebGear.Middlewares.Header+ , WebGear.Middlewares.Method+ , WebGear.Middlewares.Path+ other-modules: Paths_webgear_server+ , WebGear.Util+ autogen-modules: Paths_webgear_server+ hs-source-dirs: src++test-suite webgear-server-test+ import: webgear-common+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Unit+ , Unit.Trait.Header+ , Unit.Trait.Path+ , Properties+ , Properties.Trait.Body+ , Properties.Trait.Header+ , Properties.Trait.Method+ , Properties.Trait.Path+ hs-source-dirs: test+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends: tasty ==1.2.*+ , tasty-quickcheck ==0.10.*+ , tasty-hunit ==0.10.*+ , QuickCheck ==2.13.*+ , quickcheck-instances ==0.3.*+ , webgear-server