diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog for webgear-core + +## [Unreleased] + +## [1.0.0] - 2022-01-08 + +### Changed +- Extracted webgear-core from webgear-server +- New arrow based API + +[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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# WebGear - Core HTTP APIs + +[![Hackage](https://img.shields.io/hackage/v/webgear-core)](https://hackage.haskell.org/package/webgear-core) + +WebGear is a Haskell library for building composable, type-safe HTTP API servers. + +This package defines the core components of WebGear used to define APIs. diff --git a/src/WebGear/Core.hs b/src/WebGear/Core.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +{- | WebGear is a library to build composable, type-safe HTTP APIs. + + The modules below have haddock documentation that can be used as + reference material. If you are completely new to WebGear, a good + starting point is the [WebGear User + Guide](https://haskell-webgear.github.io/user_guide/1.0.0/index.html). Example + programs built using WebGear are available under + . + + Importing "WebGear.Core" is a quick way to get everything needed to + build WebGear API specifications. +-} +module WebGear.Core ( + module Control.Arrow, + module Data.Text, + module WebGear.Core.Trait, + module WebGear.Core.Request, + module WebGear.Core.Response, + module WebGear.Core.Modifiers, + module WebGear.Core.Handler, + module WebGear.Core.Handler.Static, + module WebGear.Core.Traits, +) where + +import Control.Arrow +import Data.Text +import qualified Network.Wai as Wai + +import WebGear.Core.Handler +import WebGear.Core.Handler.Static +import WebGear.Core.Modifiers +import WebGear.Core.Request +import WebGear.Core.Response +import WebGear.Core.Trait +import WebGear.Core.Traits diff --git a/src/WebGear/Core/Handler.hs b/src/WebGear/Core/Handler.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Handler.hs @@ -0,0 +1,88 @@ +{- | + WebGear handlers +-} +module WebGear.Core.Handler ( + Handler (..), + RoutePath (..), + RouteMismatch (..), + Description (..), + Summary (..), + RequestHandler, + Middleware, + routeMismatch, + unlinkA, +) where + +import Control.Arrow (ArrowChoice, ArrowPlus, arr) +import Control.Arrow.Operations (ArrowError (..)) +import Data.String (IsString) +import Data.Text (Text) +import GHC.Exts (IsList (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response (..)) +import WebGear.Core.Trait (Linked (unlink)) + +-- | Parts of the request path used by the routing machinery +newtype RoutePath = RoutePath [Text] + deriving newtype (Show, Eq) + +instance IsList RoutePath where + type Item RoutePath = Text + fromList = RoutePath + toList (RoutePath ps) = ps + +{- | A handler is an arrow with a monadic context. + + Handlers have the following capabilities: + + * Lift a monadic action into a handler arrow. + * Implement `ArrowChoice` typeclass so that conditionals can be used in arrow code. + * Implement `ArrowPlus` for routing requests to specific handlers. + * Provide contextual documentation elements - description and summary +-} +class (ArrowChoice h, ArrowPlus h, ArrowError RouteMismatch h, Monad m) => Handler h m | h -> m where + -- | Lift a monadic function to a handler arrow + arrM :: (a -> m b) -> h a b + + -- | Consume all remaining path components with an arrow + consumeRoute :: h RoutePath a -> h () a + + -- | Set a description of a part of an API + setDescription :: Description -> h a a + + -- | Set a summary of a part of an API + setSummary :: Summary -> h a a + +-- | A handler arrow from a linked request to response. +type RequestHandler h req = h (Linked req Request) Response + +-- | A middleware enhances a `RequestHandler` and produces another handler. +type Middleware h reqOut reqIn = RequestHandler h reqIn -> RequestHandler h reqOut + +-- | Description associated with part of an API +newtype Description = Description {getDescription :: Text} + deriving stock (Eq, Ord, Show, Read) + deriving newtype (IsString) + +-- | A summary associated with part of an API +newtype Summary = Summary {getSummary :: Text} + deriving stock (Eq, Ord, Show, Read) + deriving newtype (IsString) + +-- | Indicates that a handler cannot process this route +data RouteMismatch = RouteMismatch + deriving stock (Show, Eq, Ord) + +instance Semigroup RouteMismatch where + RouteMismatch <> RouteMismatch = RouteMismatch + +instance Monoid RouteMismatch where + mempty = RouteMismatch + +-- | Indicates that the request does not match the current handler. +routeMismatch :: ArrowError RouteMismatch h => h a b +routeMismatch = proc _a -> raise -< RouteMismatch + +-- | Lifts `unlink` into a handler arrow. +unlinkA :: Handler h m => h (Linked ts Response) Response +unlinkA = arr unlink diff --git a/src/WebGear/Core/Handler/Static.hs b/src/WebGear/Core/Handler/Static.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Handler/Static.hs @@ -0,0 +1,61 @@ +{- | + Handlers for serving static resources +-} +module WebGear.Core.Handler.Static ( + serveDir, + serveFile, +) where + +import Control.Arrow ((<<<)) +import Control.Exception.Safe (catchIO) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import qualified Network.Mime as Mime +import System.FilePath (joinPath, takeFileName, ()) +import WebGear.Core.Handler (Handler (..), RoutePath (..), unlinkA) +import WebGear.Core.Request (Request (..)) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Linked (..), Sets) +import WebGear.Core.Trait.Body (Body, setBodyWithoutContentType) +import WebGear.Core.Trait.Header (RequiredHeader, setHeader) +import WebGear.Core.Trait.Status (Status, notFound404, ok200) +import Prelude hiding (readFile) + +-- | Serve files under the specified directory. +serveDir :: + ( MonadIO m + , Handler h m + , Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response + ) => + -- | The directory to serve + FilePath -> + -- | Optional index filename for the root directory. A 404 Not Found + -- response will be returned for requests to the root path if this + -- is set to @Nothing@. + Maybe FilePath -> + h (Linked req Request) Response +serveDir root index = proc _request -> consumeRoute go -< () + where + go = proc path -> do + case (path, index) of + (RoutePath [], Nothing) -> unlinkA <<< notFound404 -< () + (RoutePath [], Just f) -> serveFile -< root f + (RoutePath ps, _) -> serveFile -< root joinPath (Text.unpack <$> ps) + +-- | Serve a file specified by the input filepath. +serveFile :: + ( MonadIO m + , Handler h m + , Sets h [Status, RequiredHeader "Content-Type" Mime.MimeType, Body LBS.ByteString] Response + ) => + h FilePath Response +serveFile = proc file -> do + maybeContents <- readFile -< file + case maybeContents of + Nothing -> unlinkA <<< notFound404 -< () + Just contents -> do + let contentType = Mime.defaultMimeLookup $ Text.pack $ takeFileName file + unlinkA <<< setHeader @"Content-Type" (setBodyWithoutContentType ok200) -< (contentType, (contents, ())) + where + readFile = arrM $ \f -> liftIO $ (Just <$> LBS.readFile f) `catchIO` const (pure Nothing) diff --git a/src/WebGear/Core/Modifiers.hs b/src/WebGear/Core/Modifiers.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Modifiers.hs @@ -0,0 +1,15 @@ +-- | Various modifiers used by traits +module WebGear.Core.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/Core/Request.hs b/src/WebGear/Core/Request.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Request.hs @@ -0,0 +1,70 @@ +{- | + Requests processed by handlers. +-} +module WebGear.Core.Request ( + -- * WebGear Request + Request (..), + remoteHost, + httpVersion, + isSecure, + requestMethod, + pathInfo, + queryString, + requestHeader, + requestHeaders, + requestBodyLength, + getRequestBodyChunk, +) where + +import Data.ByteString (ByteString) +import Data.List (find) +import Data.Text (Text) +import qualified Network.HTTP.Types as HTTP +import Network.Socket (SockAddr) +import qualified Network.Wai as Wai + +-- | A request processed by a handler +newtype Request = Request + { -- | underlying WAI request + waiRequest :: Wai.Request + } + +-- | Get the value of a request header +requestHeader :: HTTP.HeaderName -> Request -> Maybe ByteString +requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r) + +-- | See 'Wai.getRequestBodyChunk' +getRequestBodyChunk :: Request -> IO ByteString +getRequestBodyChunk = Wai.getRequestBodyChunk . waiRequest + +-- | See 'Wai.httpVersion' +httpVersion :: Request -> HTTP.HttpVersion +httpVersion = Wai.httpVersion . waiRequest + +-- | See 'Wai.isSecure' +isSecure :: Request -> Bool +isSecure = Wai.isSecure . waiRequest + +-- | See 'Wai.pathInfo' +pathInfo :: Request -> [Text] +pathInfo = Wai.pathInfo . waiRequest + +-- | See 'Wai.queryString' +queryString :: Request -> HTTP.Query +queryString = Wai.queryString . waiRequest + +-- | See 'Wai.remoteHost' +remoteHost :: Request -> SockAddr +remoteHost = Wai.remoteHost . waiRequest + +-- | See 'Wai.requestBodyLength' +requestBodyLength :: Request -> Wai.RequestBodyLength +requestBodyLength = Wai.requestBodyLength . waiRequest + +-- | See 'Wai.requestHeaders' +requestHeaders :: Request -> HTTP.RequestHeaders +requestHeaders = Wai.requestHeaders . waiRequest + +-- | See 'Wai.requestMethod' +requestMethod :: Request -> HTTP.Method +requestMethod = Wai.requestMethod . waiRequest diff --git a/src/WebGear/Core/Response.hs b/src/WebGear/Core/Response.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Response.hs @@ -0,0 +1,34 @@ +{- | + Responses from handlers. +-} +module WebGear.Core.Response ( + -- * Basic Types + Response (..), + toWaiResponse, +) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai + +-- | An HTTP response sent from the server to the client. +-- +-- The response contains a status, optional headers and an optional +-- body payload. +data Response = Response + { -- | Response status code + responseStatus :: HTTP.Status + , -- | Response headers + responseHeaders :: HM.HashMap HTTP.HeaderName ByteString + , -- | Optional response body + responseBody :: Maybe LBS.ByteString + } + deriving stock (Eq, Ord, Show) + +-- | Generate a WAI response +toWaiResponse :: Response -> Wai.Response +toWaiResponse Response{..} = + Wai.responseLBS responseStatus (HM.toList responseHeaders) (fromMaybe "" responseBody) diff --git a/src/WebGear/Core/Trait.hs b/src/WebGear/Core/Trait.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait.hs @@ -0,0 +1,181 @@ + {-# LANGUAGE UndecidableInstances #-} + +{- | 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.Core.Trait ( + -- * Core Types + Trait (..), + TraitAbsence (..), + Get (..), + Gets, + Linked, + Set (..), + Sets, + + -- * Linking values with attributes + linkzero, + linkminus, + unlink, + probe, + plant, + + -- * Retrive trait attributes from linked values + HasTrait (..), + HaveTraits, + pick, + MissingTrait, +) where + +import Control.Arrow (Arrow (..)) +import Data.Kind (Constraint, Type) +import Data.Tagged (Tagged (..), untag) +import GHC.TypeLits (ErrorMessage (..), TypeError) + +-- | A trait is an attribute @t@ associated with a value @a@. +class Trait (t :: Type) a where + -- | Type of the associated attribute when the trait holds for a + -- value + type Attribute t a :: Type + +-- | A trait @t@ that can be retrieved from @a@ but could be absent. +class Trait t a => TraitAbsence t a where + -- | Type that indicates that the trait does not exist for a + -- value. This could be an error message, exception etc. + type Absence t a :: Type + +-- | Extract trait attributes from a value. +class (Arrow h, TraitAbsence t a) => Get h t a where + -- | Attempt to deduce the trait attribute from the value @a@. + getTrait :: + -- | The trait to extract + t -> + -- | Arrow that extracts the trait and can possibly fail + h (Linked ts a) (Either (Absence t a) (Attribute t a)) + +-- | Set a trait attribute on a value +class (Arrow h, Trait t a) => Set h (t :: Type) a where + -- | Set a trait attribute @t@ on the value @a@. + setTrait :: + -- | The trait to set + t -> + -- | A function to generate a linked value. This function must be + -- called by the `setTrait` implementation to generate a linked + -- value. + (Linked ts a -> a -> Attribute t a -> Linked (t : ts) a) -> + -- | An arrow that attches a new trait attribute to a value linked + -- with other traits + h (Linked ts a, Attribute t a) (Linked (t : ts) a) + +-- | @Gets h ts a@ is equivalent to @(Get h t1 a, Get h t2 a, ..., Get +-- h tn a)@ where @ts = [t1, t2, ..., tn]@. +type family Gets h ts a :: Constraint where + Gets h '[] a = () + Gets h (t : ts) a = (Get h t a, Gets h ts a) + +-- | @Sets h ts a@ is equivalent to @(Set h t1 a, Set h t2 a, ..., Set +-- h tn a)@ where @ts = [t1, t2, ..., tn]@. +type family Sets h ts a :: Constraint where + Sets h '[] a = () + Sets h (t : ts) a = (Set h t a, Sets h ts a) + +-- | A value linked with a type-level list of traits. +data Linked (ts :: [Type]) a = Linked + { linkAttribute :: !(LinkedAttributes ts a) + , -- | Retrive the value from a linked value + unlink :: !a + } + +type family LinkedAttributes (ts :: [Type]) (a :: Type) where + LinkedAttributes '[] a = () + LinkedAttributes (t : ts) a = (Attribute t a, LinkedAttributes ts a) + +-- | Wrap a value with an empty list of traits. +linkzero :: a -> Linked '[] a +linkzero = Linked () + +-- | Forget the head trait +linkminus :: Linked (t : ts) a -> Linked ts a +linkminus (Linked (_, rv) a) = Linked rv a + +{- | Attempt to link an additional trait with an already linked + value. This can fail indicating an 'Absence' of the trait. +-} +probe :: + forall t ts h a. + Get h t a => + t -> + h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a)) +probe t = proc l -> do + res <- getTrait t -< l + arr link -< (l, res) + where + link :: (Linked ts a, Either e (Attribute t a)) -> Either e (Linked (t : ts) a) + link (_, Left e) = Left e + link (Linked{..}, Right attr) = Right $ Linked{linkAttribute = (attr, linkAttribute), ..} + +-- | Set a trait attribute on linked value to produce another linked +-- value +plant :: forall t ts h a. Set h t a => t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a) +plant t = proc (l, attr) -> do + setTrait t link -< (l, attr) + where + link :: Linked ts a -> a -> Attribute t a -> Linked (t : ts) a + link Linked{..} a' attr = Linked{linkAttribute = (attr, linkAttribute), unlink = a'} + +{- | Constraint that proves that the trait @t@ is present in the list + of traits @ts@. +-} +class HasTrait t ts where + -- | Get the attribute associated with @t@ from a linked value. See also: 'pick'. + from :: Linked ts a -> Tagged t (Attribute t a) + +instance HasTrait t (t : ts) where + from :: Linked (t : ts) a -> Tagged t (Attribute t a) + from (Linked (lv, _) _) = Tagged lv + +instance {-# OVERLAPPABLE #-} HasTrait t ts => HasTrait t (t' : ts) where + from :: Linked (t' : ts) a -> Tagged t (Attribute t a) + from l = from $ linkminus l + +{- | Retrieve a trait. + + @pick@ is used along with `from` to retrieve an attribute from a + linked value: + + > pick @t $ from val +-} +pick :: Tagged t a -> a +pick = untag + +-- For better type errors +instance TypeError (MissingTrait t) => HasTrait t '[] where + from = 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., ‘QueryParam \"foo\" Int’ instead of ‘QueryParam \"foo\" String’?" + :$$: Text "" + :$$: Text "Or did you forget to apply an appropriate middleware?" + :$$: Text "For e.g. The trait ‘JSONBody t’ can be used with ‘jsonRequestBody @t’ middleware." + :$$: Text "" + +{- | Constraint that proves that all the traits in the list @ts@ are + also present in the list @qs@. +-} +type family HaveTraits ts qs :: Constraint where + HaveTraits '[] qs = () + HaveTraits (t : ts) qs = (HasTrait t qs, HaveTraits ts qs) diff --git a/src/WebGear/Core/Trait/Auth/Basic.hs b/src/WebGear/Core/Trait/Auth/Basic.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Auth/Basic.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +{- | HTTP basic authentication support. + + Middlewares defined in this module add basic authentication support + to handlers. In most cases, you just need to use `BasicAuth` trait + and `basicAuth` middleware. The table below describes when to use + other traits and middlewares. + + +----------+-------------+-------------------------+----------------------+ + | Type | Auth Scheme | Trait | Middleware | + +----------+-------------+-------------------------+----------------------+ + | Required | Basic | 'BasicAuth' | 'basicAuth' | + +----------+-------------+-------------------------+----------------------+ + | Optional | Basic | 'BasicAuth'' 'Optional' | 'optionalBasicAuth' | + +----------+-------------+-------------------------+----------------------+ + | Required | Any scheme | 'BasicAuth'' 'Required' | 'basicAuth'' | + +----------+-------------+-------------------------+----------------------+ + | Optional | Any scheme | 'BasicAuth'' 'Optional' | 'optionalBasicAuth'' | + +----------+-------------+-------------------------+----------------------+ + + For example, given this handler: + + @ + myHandler :: ('Handler' h IO, 'HasTrait' ('BasicAuth' IO () 'Credentials') req) => 'RequestHandler' h req + myHandler = .... + @ + + and the following definitions: + + @ + authConfig :: 'BasicAuth' IO () 'Credentials' + authConfig = 'BasicAuth'' { toBasicAttribute = pure . Right } + + type ErrorTraits = [Status, RequiredHeader \"Content-Type\" Text, RequiredHeader \"WWW-Authenticate\" Text, Body Text] + + errorHandler :: ('Handler' h IO, Sets h ErrorTraits Response) + => h (Linked req Request, 'BasicAuthError' e) Response + errorHandler = 'respondUnauthorized' \"Basic\" \"MyRealm\" + @ + + we can add basic authentication to @myHandler@: + + @ + myHandlerWithAuth :: ('Handler' h IO, Get h ('BasicAuth' IO () 'Credentials') Request, Sets h ErrorTraits Response) + => 'RequestHandler' h req + myHandlerWithAuth = 'basicAuth' authConfig errorHandler myHandler + @ + + The middlewares defined below take a 'BasicAuth'' parameter which is + a newtype wrapper over a function of type @'Credentials' -> m (Either + e a)@. This is used to convert the user supplied credentials to a + value of type @a@ or fail with an error of type @e@. The next handler + is invoked after this conversion and can access @a@ as a trait + attribute. + + Middlewares marked as 'Required' take an additional error handling + arrow as a parameter. This arrow is used when an error is encountered + in authentication. This arrow receives the original request and a + 'BasicAuthError' as inputs and must produce a response as the output. + + Middlewares marked as 'Optional' do not have this additional error + handling arrow. Instead, the trait attribute is of type @Either + ('BasicAuthError' e) a@. The next handler will get the errors in this + trait attribute and must handle it. +-} +module WebGear.Core.Trait.Auth.Basic ( + BasicAuth' (..), + BasicAuth, + Realm (..), + Username (..), + Password (..), + Credentials (..), + BasicAuthError (..), + basicAuth, + basicAuth', + optionalBasicAuth, + optionalBasicAuth', +) where + +import Control.Arrow (ArrowChoice, arr) +import Data.ByteString (ByteString) +import Data.String (IsString) +import Data.Void (Void, absurd) +import GHC.TypeLits (Symbol) +import WebGear.Core.Handler +import WebGear.Core.Modifiers (Existence (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait +import WebGear.Core.Trait.Auth.Common + +-- | Trait for HTTP basic authentication: https://tools.ietf.org/html/rfc7617 +newtype BasicAuth' (x :: Existence) (scheme :: Symbol) m e a = BasicAuth' + { -- | Convert the credentials to the trait attribute or an error + toBasicAttribute :: Credentials -> m (Either e a) + } + +-- | Trait for HTTP basic authentication with the "Basic" scheme. +type BasicAuth = BasicAuth' Required "Basic" + +{- | 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 stock (Eq, Ord, Show, Read) + +-- | Error retrieving basic authentication credentials +data BasicAuthError e + = BasicAuthHeaderMissing + | BasicAuthSchemeMismatch + | BasicAuthCredsBadFormat + | BasicAuthAttributeError e + deriving stock (Eq, Show, Read) + +instance Trait (BasicAuth' Required scheme m e a) Request where + type Attribute (BasicAuth' Required scheme m e a) Request = a + +instance TraitAbsence (BasicAuth' Required scheme m e a) Request where + type Absence (BasicAuth' Required scheme m e a) Request = BasicAuthError e + +instance Trait (BasicAuth' Optional scheme m e a) Request where + type Attribute (BasicAuth' Optional scheme m e a) Request = Either (BasicAuthError e) a + +instance TraitAbsence (BasicAuth' Optional scheme m e a) Request where + type Absence (BasicAuth' Optional scheme m e a) Request = Void + +basicAuthMiddleware :: + (Get h (BasicAuth' x scheme m e t) Request, ArrowChoice h) => + BasicAuth' x scheme m e t -> + h (Linked req Request, Absence (BasicAuth' x scheme m e t) Request) Response -> + Middleware h req (BasicAuth' x scheme m e t : req) +basicAuthMiddleware authCfg errorHandler nextHandler = + proc request -> do + result <- probe authCfg -< request + case result of + Left err -> errorHandler -< (request, err) + Right val -> nextHandler -< val + +{- | Middleware to add basic authentication protection for a handler. + + Example usage: + + > basicAuth cfg errorHandler nextHandler + + The @errorHandler@ is invoked if the credentials are invalid or + missing. The @nextHandler@ is invoked if the credentials were + retrieved successfully. +-} +basicAuth :: + forall m e t h req. + (Get h (BasicAuth' Required "Basic" m e t) Request, ArrowChoice h) => + -- | Authentication configuration + BasicAuth m e t -> + -- | Error handler + h (Linked req Request, BasicAuthError e) Response -> + Middleware h req (BasicAuth m e t : req) +basicAuth = basicAuth' + +{- | Similar to `basicAuth` but supports a custom authentication scheme. + + Example usage: + + > basicAuth' @"scheme" cfg errorHandler nextHandler +-} +basicAuth' :: + forall scheme m e t h req. + (Get h (BasicAuth' Required scheme m e t) Request, ArrowChoice h) => + -- | Authentication configuration + BasicAuth' Required scheme m e t -> + -- | Error handler + h (Linked req Request, BasicAuthError e) Response -> + Middleware h req (BasicAuth' Required scheme m e t : req) +basicAuth' = basicAuthMiddleware + +{- | Middleware to add optional basic authentication protection for a handler. + + Example usage: + + > optionalBasicAuth cfg nextHandler + + This middleware will not fail if credentials are invalid or + missing. Instead the trait attribute is of type @'Either' + ('BasicAuthError' e) t@ so that the handler can process the + authentication error appropriately. +-} +optionalBasicAuth :: + forall m e t h req. + (Get h (BasicAuth' Optional "Basic" m e t) Request, ArrowChoice h) => + -- | Authentication configuration + BasicAuth' Optional "Basic" m e t -> + Middleware h req (BasicAuth' Optional "Basic" m e t : req) +optionalBasicAuth = optionalBasicAuth' + +{- | Similar to `optionalBasicAuth` but supports a custom authentication + scheme. + + Example usage: + + > optionalBasicAuth' @"scheme" cfg nextHandler +-} +optionalBasicAuth' :: + forall scheme m e t h req. + (Get h (BasicAuth' Optional scheme m e t) Request, ArrowChoice h) => + -- | Authentication configuration + BasicAuth' Optional scheme m e t -> + Middleware h req (BasicAuth' Optional scheme m e t : req) +optionalBasicAuth' cfg = basicAuthMiddleware cfg $ arr (absurd . snd) diff --git a/src/WebGear/Core/Trait/Auth/Common.hs b/src/WebGear/Core/Trait/Auth/Common.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Auth/Common.hs @@ -0,0 +1,100 @@ +{- | + Common types and functions related to authorization. +-} +module WebGear.Core.Trait.Auth.Common ( + AuthorizationHeader, + getAuthorizationHeaderTrait, + Realm (..), + AuthToken (..), + respondUnauthorized, +) where + +import Control.Arrow (returnA, (<<<)) +import Data.ByteString (ByteString, drop) +import Data.ByteString.Char8 (break) +import Data.CaseInsensitive (CI, mk, original) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Void (absurd) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import qualified Network.HTTP.Types as HTTP +import Web.HttpApiData (FromHttpApiData (..)) +import WebGear.Core.Handler (Handler, unlinkA) +import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Get (..), Linked, Sets) +import WebGear.Core.Trait.Body (Body, respondA) +import WebGear.Core.Trait.Header (Header (..), RequiredHeader, setHeader) +import WebGear.Core.Trait.Status (Status) +import Prelude hiding (break, drop) + +-- | Trait for \"Authorization\" header +type AuthorizationHeader scheme = Header Optional Lenient "Authorization" (AuthToken scheme) + +{- | Extract the \"Authorization\" header from a request by specifying + an authentication scheme. + + The header is split into the scheme and token parts and returned. +-} +getAuthorizationHeaderTrait :: + forall scheme h ts. + Get h (AuthorizationHeader scheme) Request => + h (Linked ts Request) (Maybe (Either Text (AuthToken scheme))) +getAuthorizationHeaderTrait = proc request -> do + result <- getTrait (Header :: Header Optional Lenient "Authorization" (AuthToken scheme)) -< request + returnA -< either absurd id result + +-- | The protection space for authentication +newtype Realm = Realm ByteString + deriving newtype (Eq, Ord, Show, Read, IsString) + +-- | The components of Authorization request header +data AuthToken (scheme :: Symbol) = AuthToken + { -- | Authentication scheme + authScheme :: CI ByteString + , -- | Authentication token + authToken :: ByteString + } + +instance KnownSymbol scheme => FromHttpApiData (AuthToken scheme) where + parseUrlPiece = parseHeader . encodeUtf8 + + parseHeader hdr = + case break (== ' ') hdr of + (scm, tok) -> + let actualScheme = mk scm + expectedScheme = fromString $ symbolVal $ Proxy @scheme + in if actualScheme == expectedScheme + then Right (AuthToken actualScheme (drop 1 tok)) + else Left "scheme mismatch" + +{- | Create a \"401 Unauthorized\" response. + + The response will have a plain text body and an appropriate + \"WWW-Authenticate\" header. +-} +respondUnauthorized :: + ( Handler h m + , Sets + h + [ Status + , RequiredHeader "Content-Type" Text + , RequiredHeader "WWW-Authenticate" Text + , Body Text + ] + Response + ) => + -- | The authentication scheme + CI ByteString -> + -- | The authentication realm + Realm -> + h a Response +respondUnauthorized scheme (Realm realm) = proc _ -> do + let headerVal = decodeUtf8 $ original scheme <> " realm=\"" <> realm <> "\"" + unlinkA + <<< setHeader @"WWW-Authenticate" (respondA HTTP.unauthorized401 "text/plain") + -< + (headerVal, "Unauthorized" :: Text) diff --git a/src/WebGear/Core/Trait/Auth/JWT.hs b/src/WebGear/Core/Trait/Auth/JWT.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Auth/JWT.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +{- | JWT authentication support. + + Middlewares defined in this module add JWT authentication support to + handlers. In most cases, you just need to use `JWTAuth` trait and + `jwtAuth` middleware. The table below describes when to use other + traits and middlewares. + + +----------+-------------+-----------------------+--------------------+ + | Type | Auth Scheme | Trait | Middleware | + +----------+-------------+-----------------------+--------------------+ + | Required | Bearer | 'JWTAuth' | 'jwtAuth' | + +----------+-------------+-----------------------+--------------------+ + | Optional | Bearer | 'JWTAuth'' 'Optional' | 'optionalJWTAuth' | + +----------+-------------+-----------------------+--------------------+ + | Required | Any scheme | 'JWTAuth'' 'Required' | 'jwtAuth'' | + +----------+-------------+-----------------------+--------------------+ + | Optional | Any scheme | 'JWTAuth'' 'Optional' | 'optionalJWTAuth'' | + +----------+-------------+-----------------------+--------------------+ + + For example, given this handler: + + @ + myHandler :: ('Handler' h IO, 'HasTrait' ('JWTAuth' IO () 'JWT.ClaimsSet') req) => 'RequestHandler' h req + myHandler = .... + @ + + and the following definitions: + + @ + authConfig :: 'JWTAuth' IO () 'JWT.ClaimsSet' + authConfig = 'JWTAuth'' + { jwtValidationSettings = 'JWT.defaultJWTValidationSettings' (const True) + , jwkSet = .... + , toJWTAttribute = pure . Right + } + + type ErrorTraits = [Status, RequiredHeader \"Content-Type\" Text, RequiredHeader \"WWW-Authenticate\" Text, Body Text] + + errorHandler :: ('Handler' h IO, Sets h ErrorTraits Response) + => h (Linked req Request, 'JWTAuthError' e) Response + errorHandler = 'respondUnauthorized' \"Bearer\" \"MyRealm\" + @ + + we can add JWT authentication to @myHandler@: + + @ + myHandlerWithAuth :: ('Handler' h IO, Get h ('JWTAuth' IO () 'JWT.ClaimsSet') Request, Sets h ErrorTraits Response) + => 'RequestHandler' h req + myHandlerWithAuth = 'jwtAuth' authConfig errorHandler myHandler + @ + + The middlewares defined below take a 'JWTAuth'' parameter which has + settings for validating a JWT. It also contains a function of type + @'JWT.ClaimsSet' -> m (Either e a)@. This is used to convert the set + of claims in the JWT to a value of type @a@ or fail with an error of + type @e@. In this case @a@ is the type of the trait attribute and the + next handler is invoked after this conversion. + + Middlewares marked as 'Required' take an additional error handling + arrow as a parameter. This arrow is used when an error is encountered + in authentication. This arrow receives the original request and a + 'JWTAuthError' as inputs and must produce a response as the output. + + Middlewares marked as 'Optional' do not have this additional error + handling arrow. Instead, the trait attribute is of type @Either + ('JWTAuthError' e) a@. The next handler will get the errors in this + trait attribute and must handle it. +-} +module WebGear.Core.Trait.Auth.JWT ( + JWTAuth' (..), + JWTAuth, + Realm (..), + JWTAuthError (..), + jwtAuth, + optionalJWTAuth, + jwtAuth', + optionalJWTAuth', +) where + +import Control.Arrow (ArrowChoice, arr) +import qualified Crypto.JWT as JWT +import Data.Void (Void, absurd) +import GHC.TypeLits (Symbol) +import WebGear.Core.Handler +import WebGear.Core.Modifiers (Existence (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait +import WebGear.Core.Trait.Auth.Common + +{- | Trait for JWT authentication with a bearer token: + https://tools.ietf.org/html/rfc6750 + + This trait supports a custom scheme instead of the standard + \"Bearer\" scheme. +-} +data JWTAuth' (x :: Existence) (scheme :: Symbol) m e a = JWTAuth' + { -- | Settings to validate the JWT + jwtValidationSettings :: JWT.JWTValidationSettings + , -- | JWK to validate the JWT + jwkSet :: JWT.JWKSet + , -- | Convert the claims set to the trait attribute or an error + toJWTAttribute :: JWT.ClaimsSet -> m (Either e a) + } + +-- | Trait for JWT authentication with the \"Bearer\" scheme +type JWTAuth = JWTAuth' Required "Bearer" + +-- | Error extracting a JWT from a request +data JWTAuthError e + = JWTAuthHeaderMissing + | JWTAuthSchemeMismatch + | JWTAuthTokenBadFormat JWT.JWTError + | JWTAuthAttributeError e + deriving stock (Eq, Show) + +instance WebGear.Core.Trait.Trait (JWTAuth' Required scheme m e a) Request where + type Attribute (JWTAuth' Required scheme m e a) Request = a + +instance WebGear.Core.Trait.TraitAbsence (JWTAuth' Required scheme m e a) Request where + type Absence (JWTAuth' Required scheme m e a) Request = JWTAuthError e + +instance WebGear.Core.Trait.Trait (JWTAuth' Optional scheme m e a) Request where + type Attribute (JWTAuth' Optional scheme m e a) Request = Either (JWTAuthError e) a + +instance WebGear.Core.Trait.TraitAbsence (JWTAuth' Optional scheme m e a) Request where + type Absence (JWTAuth' Optional scheme m e a) Request = Void + +{- | Middleware to add JWT authentication protection for a + handler. Expects the JWT to be available via a standard bearer + authorization header in the format: + + > Authorization: Bearer + + Example usage: + + > jwtAuth cfg errorHandler nextHandler + + The @errorHandler@ is invoked if the credentials are invalid or + missing. The @nextHandler@ is invoked if the credentials were + retrieved successfully. +-} +jwtAuth :: + ( WebGear.Core.Trait.Get h (JWTAuth m e t) Request + , ArrowChoice h + ) => + -- | Authentication configuration + JWTAuth m e t -> + -- | Error handler + h (WebGear.Core.Trait.Linked req Request, JWTAuthError e) Response -> + Middleware h req (JWTAuth m e t : req) +jwtAuth = jwtAuth' @"Bearer" + +{- | Middleware to add optional JWT authentication protection for a + handler. Expects the JWT to be available via a standard bearer + authorization header in the format: + + > Authorization: Bearer + + Example usage: + + > optionalJWTAuth cfg handler + + This middleware will not fail if authorization credentials are + invalid or missing. Instead the trait attribute is of type @'Either' + ('JWTAuthError' e) t@ so that the handler can process the + authentication error appropriately. +-} +optionalJWTAuth :: + ( WebGear.Core.Trait.Get h (JWTAuth' Optional "Bearer" m e t) Request + , ArrowChoice h + ) => + -- | Authentication configuration + JWTAuth' Optional "Bearer" m e t -> + Middleware h req (JWTAuth' Optional "Bearer" m e t : req) +optionalJWTAuth = optionalJWTAuth' @"Bearer" + +jwtAuthMiddleware :: + forall s e t x h m req. + ( WebGear.Core.Trait.Get h (JWTAuth' x s m e t) Request + , ArrowChoice h + ) => + JWTAuth' x s m e t -> + h (WebGear.Core.Trait.Linked req Request, WebGear.Core.Trait.Absence (JWTAuth' x s m e t) Request) Response -> + Middleware h req (JWTAuth' x s m e t : req) +jwtAuthMiddleware authCfg errorHandler nextHandler = + proc request -> do + result <- WebGear.Core.Trait.probe authCfg -< request + case result of + Left err -> errorHandler -< (request, err) + Right val -> nextHandler -< val + +{- | Middleware to add JWT authentication protection for a + handler. Expects the JWT to be available via an authorization header + in the format: + + > Authorization: + + Example usage: + + > jwtAuth' @"" cfg errorHandler nextHandler + + The @errorHandler@ is invoked if the credentials are invalid or + missing. The @nextHandler@ is invoked if the credentials were + retrieved successfully. +-} +jwtAuth' :: + forall s e t h m req. + ( WebGear.Core.Trait.Get h (JWTAuth' Required s m e t) Request + , ArrowChoice h + ) => + -- | Authentication configuration + JWTAuth' Required s m e t -> + -- | Error handler + h (WebGear.Core.Trait.Linked req Request, JWTAuthError e) Response -> + Middleware h req (JWTAuth' Required s m e t : req) +jwtAuth' = jwtAuthMiddleware + +{- | Middleware to add JWT authentication protection for a + handler. Expects the JWT to be available via an authorization header + in the format: + + > Authorization: + + Example usage: + + > optionalJWTAuth' @"" cfg nextHandler + + This middleware will not fail if authorization credentials are + invalid or missing. Instead the trait attribute is of type @'Either' + ('JWTAuthError' e) t@ so that the handler can process the + authentication error appropriately. +-} +optionalJWTAuth' :: + forall s e t h m req. + ( WebGear.Core.Trait.Get h (JWTAuth' Optional s m e t) Request + , ArrowChoice h + ) => + -- | Authentication configuration + JWTAuth' Optional s m e t -> + Middleware h req (JWTAuth' Optional s m e t : req) +optionalJWTAuth' cfg = jwtAuthMiddleware cfg $ arr (absurd . snd) diff --git a/src/WebGear/Core/Trait/Body.hs b/src/WebGear/Core/Trait/Body.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Body.hs @@ -0,0 +1,252 @@ +{- | Traits and middlewares to handle request and response body + payloads. + + There are a number of ways to extract a body from a request: + + The 'requestBody' middleware attempts to convert the body to a + Haskell value or invoke an error handler if that fails. + + The 'jsonRequestBody' middleware attempts to convert a JSON + formatted body to a Haskell value or invoke an error handler if that + fails. It uses the standard "application/json" media type. + + The 'jsonRequestBody'' middleware is similar but supports custom + media types. + + Similarly, there are a number of ways to set a response body: + + The easiest option is to use one of 'respondA', 'respondJsonA', or + 'respondJsonA'' middlewares. These middlewares generate a response + from an HTTP status and a response body. + + If you need finer control over setting the body, use one of + 'setBody', 'setBodyWithoutContentType', 'setJSONBody', + 'setJSONBodyWithoutContentType', or 'setJSONBody''. These arrows + accept a linked response and a body and sets the body in the + response. You can generate an input response object using functions + from "WebGear.Core.Trait.Status" module. +-} +module WebGear.Core.Trait.Body ( + -- * Traits + Body (..), + JSONBody (..), + + -- * Middlewares + requestBody, + jsonRequestBody', + jsonRequestBody, + respondA, + respondJsonA, + respondJsonA', + setBody, + setBodyWithoutContentType, + setJSONBody, + setJSONBodyWithoutContentType, + setJSONBody', +) where + +import Control.Arrow (ArrowChoice) +import Data.Kind (Type) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import qualified Network.HTTP.Media as HTTP +import qualified Network.HTTP.Types as HTTP +import WebGear.Core.Handler (Middleware) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Get, Linked, Set, Sets, Trait (..), TraitAbsence (..), plant, probe) +import WebGear.Core.Trait.Header (Header (..), RequiredHeader) +import WebGear.Core.Trait.Status (Status, mkResponse) + +-- | Request or response body with a type @t@. +newtype Body (t :: Type) = Body (Maybe HTTP.MediaType) + +instance Trait (Body t) Request where + type Attribute (Body t) Request = t + +instance TraitAbsence (Body t) Request where + type Absence (Body t) Request = Text + +instance Trait (Body t) Response where + type Attribute (Body t) Response = t + +-- | A 'Trait' for converting a JSON formatted body into a value. +newtype JSONBody (t :: Type) = JSONBody (Maybe HTTP.MediaType) + +instance Trait (JSONBody t) Request where + type Attribute (JSONBody t) Request = t + +instance TraitAbsence (JSONBody t) Request where + type Absence (JSONBody t) Request = Text + +instance Trait (JSONBody t) Response where + type Attribute (JSONBody t) Response = t + +{- | Middleware to extract a request body. + + The @nextHandler@ is invoked after successfully extracting the body + and the @errorHandler@ is invoked when there is an error. + + Usage: + + > requestBody @t (Just "text/plain") errorHandler nextHandler +-} +requestBody :: + forall t h req. + (Get h (Body t) Request, ArrowChoice h) => + -- | Optional media type of the body + Maybe HTTP.MediaType -> + -- | Error handler in case body cannot be retrieved + h (Linked req Request, Text) Response -> + Middleware h req (Body t : req) +requestBody mediaType errorHandler nextHandler = proc request -> do + result <- probe (Body mediaType) -< request + case result of + Left err -> errorHandler -< (request, err) + Right t -> nextHandler -< t + +{- | Parse the request body as JSON and convert it to a value of type + @t@. + + The @nextHandler@ is invoked when the body is parsed successfully and + the @errorHandler@ is invoked when there is a parsing failure. + + Usage: + + > jsonRequestBody @t errorHandler nextHandler +-} +jsonRequestBody' :: + forall t h req. + (Get h (JSONBody t) Request, ArrowChoice h) => + -- | Optional media type of the body + Maybe HTTP.MediaType -> + -- | Error handler in case body cannot be retrieved + h (Linked req Request, Text) Response -> + Middleware h req (JSONBody t : req) +jsonRequestBody' mediaType errorHandler nextHandler = proc request -> do + result <- probe (JSONBody mediaType) -< request + case result of + Left err -> errorHandler -< (request, err) + Right t -> nextHandler -< t + +-- | Same as 'jsonRequestBody'' but with a media type @application/json@. +jsonRequestBody :: + forall t h req. + (Get h (JSONBody t) Request, ArrowChoice h) => + -- | error handler + h (Linked req Request, Text) Response -> + Middleware h req (JSONBody t : req) +jsonRequestBody = jsonRequestBody' (Just "application/json") + +{- | Set the response body along with a media type. + + The media type value is used to set the "Content-Type" header in the response. +-} +setBody :: + forall body a h ts. + Sets h [Body body, RequiredHeader "Content-Type" Text] Response => + -- | The media type of the response body + HTTP.MediaType -> + h a (Linked ts Response) -> + h (body, a) (Linked (RequiredHeader "Content-Type" Text : Body body : ts) Response) +setBody mediaType prevHandler = proc (body, a) -> do + r <- prevHandler -< a + r' <- plant (Body (Just mediaType)) -< (r, body) + let mt = decodeUtf8 $ HTTP.renderHeader mediaType + plant Header -< (r', mt) + +-- | Set the response body without specifying any media type. +setBodyWithoutContentType :: + forall body a h ts. + Set h (Body body) Response => + h a (Linked ts Response) -> + h (body, a) (Linked (Body body : ts) Response) +setBodyWithoutContentType prevHandler = proc (body, a) -> do + r <- prevHandler -< a + plant (Body Nothing) -< (r, body) + +{- | Set the response body to a JSON value along with a media type. + + The media type value is used to set the "Content-Type" header in the response. +-} +setJSONBody' :: + forall body a h ts. + Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response => + -- | The media type of the response body + HTTP.MediaType -> + h a (Linked ts Response) -> + h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response) +setJSONBody' mediaType prevHandler = proc (body, a) -> do + r <- prevHandler -< a + r' <- plant (JSONBody (Just mediaType)) -< (r, body) + let mt = decodeUtf8 $ HTTP.renderHeader mediaType + plant Header -< (r', mt) + +{- | Set the response body to a JSON value. + + The "Content-Type" header will be set to "application/json". +-} +setJSONBody :: + forall body a h ts. + Sets h [JSONBody body, RequiredHeader "Content-Type" Text] Response => + h a (Linked ts Response) -> + h (body, a) (Linked (RequiredHeader "Content-Type" Text : JSONBody body : ts) Response) +setJSONBody = setJSONBody' "application/json" + +{- | Set the response body to a JSON value without specifying any + media type. +-} +setJSONBodyWithoutContentType :: + forall body a h ts. + Set h (JSONBody body) Response => + h a (Linked ts Response) -> + h (body, a) (Linked (JSONBody body : ts) Response) +setJSONBodyWithoutContentType prevHandler = proc (body, a) -> do + r <- prevHandler -< a + plant (JSONBody Nothing) -< (r, body) + +{- | A convenience arrow to generate a response specifying a status and body. + + The "Content-Type" header will be set to the specified media type + value. +-} +respondA :: + forall body h. + Sets h [Status, Body body, RequiredHeader "Content-Type" Text] Response => + -- | Response status + HTTP.Status -> + -- | Media type of the response body + HTTP.MediaType -> + h body (Linked [RequiredHeader "Content-Type" Text, Body body, Status] Response) +respondA status mediaType = proc body -> + setBody mediaType (mkResponse status) -< (body, ()) + +{- | A convenience arrow to generate a response specifying a status and + JSON body. + + The "Content-Type" header will be set to "application/json". +-} +respondJsonA :: + forall body h. + Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response => + -- | Response status + HTTP.Status -> + h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response) +respondJsonA status = respondJsonA' status "application/json" + +{- | A convenience arrow to generate a response specifying a status and + JSON body. + + The "Content-Type" header will be set to the specified media type + value. +-} +respondJsonA' :: + forall body h. + Sets h [Status, JSONBody body, RequiredHeader "Content-Type" Text] Response => + -- | Response status + HTTP.Status -> + -- | Media type of the response body + HTTP.MediaType -> + h body (Linked [RequiredHeader "Content-Type" Text, JSONBody body, Status] Response) +respondJsonA' status mediaType = proc body -> + setJSONBody' mediaType (mkResponse status) -< (body, ()) diff --git a/src/WebGear/Core/Trait/Header.hs b/src/WebGear/Core/Trait/Header.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Header.hs @@ -0,0 +1,219 @@ +{- | Traits and middlewares to handle request and response headers. + + There are a number of ways to extract a header value from a request: + + The `header` middleware can extract a header value trait and invoke + another handler. An error handler is invoked if the header is missing + or the parsing fails. + + The `optionalHeader` middleware is similar but will not invoke the + error handling in case the header is missing. Instead, the trait + value will be set to `Nothing` in that case. + + The `lenientHeader` middleware requires the header to be present. But + the trait attribute will be set to 'Left' @msg@ if an error occurs + while parsing it to a Haskell value. Here @msg@ will indicate the + error in parsing. + + Finally, we have `optionalLenientHeader` which combines the behaviors + of `optionalHeader` and `lenientHeader`. In this case, the header + extraction never fails. Missing headers and parse errors are + indicated in the trait attribute passed to next handler. + + A response header can be set using `setHeader` or `setOptionalHeader` + arrows. They accept a linked response and a header value and sets the + header in the response. You can generate an input response object + using functions from "WebGear.Core.Trait.Status" module. +-} +module WebGear.Core.Trait.Header ( + -- * Traits + Header (..), + HeaderNotFound (..), + HeaderParseError (..), + RequiredHeader, + OptionalHeader, + + -- * Middlewares + header, + optionalHeader, + lenientHeader, + optionalLenientHeader, + setHeader, + setOptionalHeader, +) where + +import Control.Arrow (ArrowChoice, arr) +import Data.Kind (Type) +import Data.Text (Text) +import Data.Void (Void, absurd) +import GHC.TypeLits (Symbol) +import WebGear.Core.Handler (Middleware) +import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Get (..), Linked, Set, Trait (..), TraitAbsence (..), plant, probe) + +-- | 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) + +{- | A 'Trait' for capturing an HTTP header of specified @name@ and + converting it to some type @val@. 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) = Header + +-- | A `Header` that is required and parsed strictly +type RequiredHeader = Header Required Strict + +-- | A `Header` that is optional and parsed strictly +type OptionalHeader = Header Optional Strict + +instance Trait (Header Required Strict name val) Request where + type Attribute (Header Required Strict name val) Request = val + +instance TraitAbsence (Header Required Strict name val) Request where + type Absence (Header Required Strict name val) Request = Either HeaderNotFound HeaderParseError + +instance Trait (Header Optional Strict name val) Request where + type Attribute (Header Optional Strict name val) Request = Maybe val + +instance TraitAbsence (Header Optional Strict name val) Request where + type Absence (Header Optional Strict name val) Request = HeaderParseError + +instance Trait (Header Required Lenient name val) Request where + type Attribute (Header Required Lenient name val) Request = Either Text val + +instance TraitAbsence (Header Required Lenient name val) Request where + type Absence (Header Required Lenient name val) Request = HeaderNotFound + +instance Trait (Header Optional Lenient name val) Request where + type Attribute (Header Optional Lenient name val) Request = Maybe (Either Text val) + +instance TraitAbsence (Header Optional Lenient name val) Request where + type Absence (Header Optional Lenient name val) Request = Void + +headerHandler :: + forall name val e p h req. + (Get h (Header e p name val) Request, ArrowChoice h) => + -- | error handler + h (Linked req Request, Absence (Header e p name val) Request) Response -> + Middleware h req (Header e p name val : req) +headerHandler errorHandler nextHandler = proc request -> do + result <- probe Header -< request + case result of + Left err -> errorHandler -< (request, err) + Right val -> nextHandler -< val + +{- | Extract a header value and convert it to a value of type @val@. + + The associated trait attribute has type @val@. + + Example usage: + + > header @"Content-Length" @Integer errorHandler okHandler +-} +header :: + forall name val h req. + (Get h (Header Required Strict name val) Request, ArrowChoice h) => + -- | Error handler + h (Linked req Request, Either HeaderNotFound HeaderParseError) Response -> + Middleware h req (Header Required Strict name val : req) +header = headerHandler + +{- | Extract an optional header value and convert it to a value of type + @val@. + + The associated trait attribute has type @Maybe val@; a @Nothing@ + value indicates that the header is missing from the request. + + Example usage: + + > optionalHeader @"Content-Length" @Integer errorHandler okHandler +-} +optionalHeader :: + forall name val h req. + (Get h (Header Optional Strict name val) Request, ArrowChoice h) => + -- | Error handler + h (Linked req Request, HeaderParseError) Response -> + Middleware h req (Header Optional Strict name val : req) +optionalHeader = headerHandler + +{- | Extract a header value and convert it to a value of type @val@. + + The associated trait attribute has type @Either Text val@. The + parsing is done leniently and any errors are reported in the trait + attribute. + + Example usage: + + > lenientHeader @"Content-Length" @Integer errorHandler okHandler +-} +lenientHeader :: + forall name val h req. + (Get h (Header Required Lenient name val) Request, ArrowChoice h) => + -- | Error handler + h (Linked req Request, HeaderNotFound) Response -> + Middleware h req (Header Required Lenient name val : req) +lenientHeader = headerHandler + +{- | Extract a header value and convert it to a value of type @val@. + + The associated trait attribute has type @Maybe (Either Text + val)@. The parsing is done leniently. Any parsing errors and + missing header are reported in the trait attribute. + + Example usage: + + > optionalLenientHeader @"Content-Length" @Integer handler +-} +optionalLenientHeader :: + forall name val h req. + (Get h (Header Optional Lenient name val) Request, ArrowChoice h) => + Middleware h req (Header Optional Lenient name val : req) +optionalLenientHeader = headerHandler $ arr (absurd . snd) + +instance Trait (Header Required Strict name val) Response where + type Attribute (Header Required Strict name val) Response = val + +instance Trait (Header Optional Strict name val) Response where + type Attribute (Header Optional Strict name val) Response = Maybe val + +{- | Set a header value in a response. + + Example usage: + + > response' <- setHeader @"Content-Length" -< (response, 42) +-} +setHeader :: + forall name val a h res. + Set h (Header Required Strict name val) Response => + h a (Linked res Response) -> + h (val, a) (Linked (Header Required Strict name val : res) Response) +setHeader prevHandler = proc (val, a) -> do + r <- prevHandler -< a + plant Header -< (r, val) + +{- | Set an optional header value in a response. + + Setting the header to 'Nothing' will remove it from the response if + it was previously set. The header will be considered as optional in + all relevant places (such as documentation). + + Example usage: + + > response' <- setOptionalHeader @"Content-Length" -< (response, Just 42) +-} +setOptionalHeader :: + forall name val a h res. + Set h (Header Optional Strict name val) Response => + h a (Linked res Response) -> + h (Maybe val, a) (Linked (Header Optional Strict name val : res) Response) +setOptionalHeader prevHandler = proc (val, a) -> do + r <- prevHandler -< a + plant Header -< (r, val) diff --git a/src/WebGear/Core/Trait/Method.hs b/src/WebGear/Core/Trait/Method.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Method.hs @@ -0,0 +1,47 @@ +-- | Traits and middlewares to handle HTTP methods. +module WebGear.Core.Trait.Method ( + Method (..), + MethodMismatch (..), + method, +) where + +import Control.Arrow (ArrowChoice (..), (>>>)) +import Control.Arrow.Operations (ArrowError) +import qualified Network.HTTP.Types as HTTP +import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch) +import WebGear.Core.Request (Request) +import WebGear.Core.Trait (Get (..), Trait (..), TraitAbsence (..), probe) + +-- | A 'Trait' for capturing the HTTP method of a request +newtype Method = Method HTTP.StdMethod + +-- | Failure to match method against an expected value +data MethodMismatch = MethodMismatch + { expectedMethod :: HTTP.Method + , actualMethod :: HTTP.Method + } + +instance Trait Method Request where + type Attribute Method Request = HTTP.StdMethod + +instance TraitAbsence Method Request where + type Absence Method Request = MethodMismatch + +{- | Check whether the request has a specified HTTP method. + + Example usage: + + > method @GET handler + + If the request does not have the specified method, another handler + will be tried. + + It is also idiomatic to use the template haskell quasiquoter + 'WebGear.Core.Trait.Path.match' or 'WebGear.Core.Trait.Path.route' in + cases where both an HTTP method and a path need to be matched. +-} +method :: + (Get h Method Request, ArrowChoice h, ArrowError RouteMismatch h) => + HTTP.StdMethod -> + Middleware h req (Method : req) +method m nextHandler = probe (Method m) >>> routeMismatch ||| nextHandler diff --git a/src/WebGear/Core/Trait/Path.hs b/src/WebGear/Core/Trait/Path.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Path.hs @@ -0,0 +1,216 @@ +{- | Middlewares related to request paths. + + All the middlewares below attempt to match components of the request + path. In case of a mismatch, they abandon the current handler and + tries the next handler. +-} +module WebGear.Core.Trait.Path ( + Path (..), + PathVar (..), + PathVarError (..), + PathEnd (..), + path, + pathVar, + pathEnd, + match, + route, +) where + +import Control.Arrow (ArrowChoice (..), (>>>)) +import Control.Arrow.Operations (ArrowError) +import Data.Function ((&)) +import Data.Kind (Type) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..), filter, toList) +import Data.Text (Text) +import GHC.TypeLits (Symbol) +import Language.Haskell.TH (appE, conE) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax (Exp (..), Lit (..), Q, TyLit (StrTyLit), Type (..), mkName) +import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch) +import WebGear.Core.Request (Request) +import WebGear.Core.Trait (Get, Trait (..), TraitAbsence (..), probe) +import WebGear.Core.Trait.Method (method) +import Prelude hiding (drop, filter, take) + +{- | A path component which is literally matched against the request + but discarded after that. +-} +newtype Path = Path Text + +instance Trait Path Request where + type Attribute Path Request = () + +instance TraitAbsence Path Request where + type Absence Path Request = () + +{- | 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 :: Symbol) (val :: Data.Kind.Type) = PathVar + +-- | Failure to extract a 'PathVar' +data PathVarError = PathVarNotFound | PathVarParseError Text + deriving stock (Eq, Show, Read) + +instance Trait (PathVar tag val) Request where + type Attribute (PathVar tag val) Request = val + +instance TraitAbsence (PathVar tag val) Request where + type Absence (PathVar tag val) Request = PathVarError + +-- | Trait to indicate that no more path components are present in the request +data PathEnd = PathEnd + +instance Trait PathEnd Request where + type Attribute PathEnd Request = () + +instance TraitAbsence PathEnd Request where + type Absence PathEnd Request = () + +{- | 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 :: + (Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) => + Text -> + Middleware h req (Path : req) +path s nextHandler = probe (Path s) >>> routeMismatch ||| nextHandler + +{- | A middleware that captures a path variable from a single path + component. + + The value captured is converted to a value of type @val@. 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 h req. + (Get h (PathVar tag val) Request, ArrowChoice h, ArrowError RouteMismatch h) => + Middleware h req (PathVar tag val : req) +pathVar nextHandler = probe PathVar >>> routeMismatch ||| nextHandler + +-- | A middleware that verifies that end of path is reached. +pathEnd :: + (Get h PathEnd Request, ArrowChoice h, ArrowError RouteMismatch h) => + Middleware h req (PathEnd : req) +pathEnd nextHandler = probe PathEnd >>> routeMismatch ||| nextHandler + +{- | 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] -> toMethodAndPathExps m p + [p] -> do + pathExps <- toPathExps p + pure $ List.foldr1 compose pathExps + _ -> fail "Expected an HTTP method and a path or just a path" + where + toMethodAndPathExps :: String -> String -> Q Exp + toMethodAndPathExps m p = do + methodExp <- [|method|] `appE` conE (mkName m) + pathExps <- toPathExps p + pure $ List.foldr1 compose $ methodExp :| pathExps + + toPathExps :: String -> Q [Exp] + toPathExps p = + splitOn '/' p + & filter (/= "") + & fmap (splitOn ':') + & List.foldr joinPath [] + & mapM toPathExp + + 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 $ AppE (VarE 'path) (LitE $ StringL 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 ".") + +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 diff --git a/src/WebGear/Core/Trait/QueryParam.hs b/src/WebGear/Core/Trait/QueryParam.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/QueryParam.hs @@ -0,0 +1,169 @@ +{- | Traits and middleware to handle request query parameters. + + The `queryParam` middleware can extract a query parameter value trait + and invoke another handler. An error handler is invoked if the parameter + is missing or the parsing fails. + + The `optionalQueryParam` middleware is similar but will not invoke + the error handling in case the prameter is missing. Instead, the + trait value will be set to `Nothing` in that case. + + The `lenientQueryParam` middleware requires the parameter to be + present. But the trait attribute will be set to 'Left' @msg@ if an + error occurs while parsing it to a Haskell value. Here @msg@ will + indicate the error in parsing. + + Finally, we have `optionalLenientQueryParam` which combines the + behaviors of `optionalQueryParam` and `lenientQueryParam`. In this + case, the parameter extraction never fails. Missing parameters and + parse errors are indicated in the trait attribute passed to next + handler. +-} +module WebGear.Core.Trait.QueryParam ( + -- * Traits + QueryParam (..), + RequiredQueryParam, + OptionalQueryParam, + ParamNotFound (..), + ParamParseError (..), + + -- * Middlewares + queryParam, + optionalQueryParam, + lenientQueryParam, + optionalLenientQueryParam, +) where + +import Control.Arrow (ArrowChoice, arr) +import Data.Kind (Type) +import Data.Text (Text) +import Data.Void (Void, absurd) +import GHC.TypeLits (Symbol) +import WebGear.Core.Handler (Middleware) +import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Get, Linked, Trait (..), TraitAbsence (..), probe) + +{- | Capture a query parameter with a specified @name@ and convert it to + a value of type @val@. 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 :: Type) = QueryParam + +-- | `QueryParam` that is required and parsed strictly +type RequiredQueryParam = QueryParam Required Strict + +-- | `QueryParam` that is optional and parsed strictly +type OptionalQueryParam = QueryParam Optional Strict + +-- | 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) + +instance Trait (QueryParam Required Strict name val) Request where + type Attribute (QueryParam Required Strict name val) Request = val + +instance TraitAbsence (QueryParam Required Strict name val) Request where + type Absence (QueryParam Required Strict name val) Request = Either ParamNotFound ParamParseError + +instance Trait (QueryParam Optional Strict name val) Request where + type Attribute (QueryParam Optional Strict name val) Request = Maybe val + +instance TraitAbsence (QueryParam Optional Strict name val) Request where + type Absence (QueryParam Optional Strict name val) Request = ParamParseError + +instance Trait (QueryParam Required Lenient name val) Request where + type Attribute (QueryParam Required Lenient name val) Request = Either Text val + +instance TraitAbsence (QueryParam Required Lenient name val) Request where + type Absence (QueryParam Required Lenient name val) Request = ParamNotFound + +instance Trait (QueryParam Optional Lenient name val) Request where + type Attribute (QueryParam Optional Lenient name val) Request = Maybe (Either Text val) + +instance TraitAbsence (QueryParam Optional Lenient name val) Request where + type Absence (QueryParam Optional Lenient name val) Request = Void + +queryParamHandler :: + forall name val e p h req. + (Get h (QueryParam e p name val) Request, ArrowChoice h) => + h (Linked req Request, Absence (QueryParam e p name val) Request) Response -> + Middleware h req (QueryParam e p name val : req) +queryParamHandler errorHandler nextHandler = proc request -> do + result <- probe QueryParam -< request + case result of + Left err -> errorHandler -< (request, err) + Right val -> nextHandler -< val + +{- | Extract a query parameter and convert it to a value of type + @val@. + + The associated trait attribute has type @val@. + + Example usage: + + > queryParam @"limit" @Integer errorHandler okHandler +-} +queryParam :: + forall name val h req. + (Get h (QueryParam Required Strict name val) Request, ArrowChoice h) => + h (Linked req Request, Either ParamNotFound ParamParseError) Response -> + Middleware h req (QueryParam Required Strict name val : req) +queryParam = queryParamHandler + +{- | Extract an optional query parameter and convert it to a value of + type @val@. + + The associated trait attribute has type @Maybe val@; a @Nothing@ + value indicates that the parameter is missing from the request. + + Example usage: + + > optionalQueryParam @"limit" @Integer errorHandler okHandler +-} +optionalQueryParam :: + forall name val h req. + (Get h (QueryParam Optional Strict name val) Request, ArrowChoice h) => + h (Linked req Request, ParamParseError) Response -> + Middleware h req (QueryParam Optional Strict name val : req) +optionalQueryParam = queryParamHandler + +{- | Extract a query parameter and convert it to a value of type @val@. + + The associated trait attribute has type @Either Text val@. The + parsing is done leniently and any errors are reported in the trait + attribute. + + Example usage: + + > lenientQueryParam @"limit" @Integer errorHandler okHandler +-} +lenientQueryParam :: + forall name val h req. + (Get h (QueryParam Required Lenient name val) Request, ArrowChoice h) => + h (Linked req Request, ParamNotFound) Response -> + Middleware h req (QueryParam Required Lenient name val : req) +lenientQueryParam = queryParamHandler + +{- | Extract a query parameter and convert it to a value of type @val@. + + Example usage: + + > optionalLenientQueryParam @"Content-Length" @Integer handler + + The associated trait attribute has type @Maybe (Either Text + val)@. The parsing is done leniently. Any parsing errors and + missing query parameters are reported in the trait attribute. +-} +optionalLenientQueryParam :: + forall name val h req. + (Get h (QueryParam Optional Lenient name val) Request, ArrowChoice h) => + Middleware h req (QueryParam Optional Lenient name val : req) +optionalLenientQueryParam = queryParamHandler $ arr (absurd . snd) diff --git a/src/WebGear/Core/Trait/Status.hs b/src/WebGear/Core/Trait/Status.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Trait/Status.hs @@ -0,0 +1,253 @@ +-- | Generate responses based on their HTTP status +module WebGear.Core.Trait.Status ( + Status (..), + + -- * Create responses + mkResponse, + 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, +) where + +import qualified Network.HTTP.Types as HTTP +import WebGear.Core.Response (Response (..)) +import WebGear.Core.Trait (Linked, Set, Trait (..), linkzero, plant) + +-- | HTTP response status +newtype Status = Status HTTP.Status + +instance Trait Status Response where + type Attribute Status Response = HTTP.Status + +-- | Generate a response with the specified status +mkResponse :: Set h Status Response => HTTP.Status -> h () (Linked '[Status] Response) +mkResponse status = proc () -> do + let response = linkzero $ Response status [] Nothing + plant (Status status) -< (response, status) + +-- | Continue 100 response +continue100 :: Set h Status Response => h () (Linked '[Status] Response) +continue100 = mkResponse HTTP.continue100 + +-- | Switching Protocols 101 response +switchingProtocols101 :: Set h Status Response => h () (Linked '[Status] Response) +switchingProtocols101 = mkResponse HTTP.switchingProtocols101 + +-- | OK 200 response +ok200 :: Set h Status Response => h () (Linked '[Status] Response) +ok200 = mkResponse HTTP.ok200 + +-- | Created 201 response +created201 :: Set h Status Response => h () (Linked '[Status] Response) +created201 = mkResponse HTTP.created201 + +-- | Accepted 202 response +accepted202 :: Set h Status Response => h () (Linked '[Status] Response) +accepted202 = mkResponse HTTP.accepted202 + +-- | Non-Authoritative 203 response +nonAuthoritative203 :: Set h Status Response => h () (Linked '[Status] Response) +nonAuthoritative203 = mkResponse HTTP.nonAuthoritative203 + +-- | No Content 204 response +noContent204 :: Set h Status Response => h () (Linked '[Status] Response) +noContent204 = mkResponse HTTP.noContent204 + +-- | Reset Content 205 response +resetContent205 :: Set h Status Response => h () (Linked '[Status] Response) +resetContent205 = mkResponse HTTP.resetContent205 + +-- | Partial Content 206 response +partialContent206 :: Set h Status Response => h () (Linked '[Status] Response) +partialContent206 = mkResponse HTTP.partialContent206 + +-- | Multiple Choices 300 response +multipleChoices300 :: Set h Status Response => h () (Linked '[Status] Response) +multipleChoices300 = mkResponse HTTP.multipleChoices300 + +-- | Moved Permanently 301 response +movedPermanently301 :: Set h Status Response => h () (Linked '[Status] Response) +movedPermanently301 = mkResponse HTTP.movedPermanently301 + +-- | Found 302 response +found302 :: Set h Status Response => h () (Linked '[Status] Response) +found302 = mkResponse HTTP.found302 + +-- | See Other 303 response +seeOther303 :: Set h Status Response => h () (Linked '[Status] Response) +seeOther303 = mkResponse HTTP.seeOther303 + +-- | Not Modified 304 response +notModified304 :: Set h Status Response => h () (Linked '[Status] Response) +notModified304 = mkResponse HTTP.notModified304 + +-- | Temporary Redirect 307 response +temporaryRedirect307 :: Set h Status Response => h () (Linked '[Status] Response) +temporaryRedirect307 = mkResponse HTTP.temporaryRedirect307 + +-- | Permanent Redirect 308 response +permanentRedirect308 :: Set h Status Response => h () (Linked '[Status] Response) +permanentRedirect308 = mkResponse HTTP.permanentRedirect308 + +-- | Bad Request 400 response +badRequest400 :: Set h Status Response => h () (Linked '[Status] Response) +badRequest400 = mkResponse HTTP.badRequest400 + +-- | Unauthorized 401 response +unauthorized401 :: Set h Status Response => h () (Linked '[Status] Response) +unauthorized401 = mkResponse HTTP.unauthorized401 + +-- | Payment Required 402 response +paymentRequired402 :: Set h Status Response => h () (Linked '[Status] Response) +paymentRequired402 = mkResponse HTTP.paymentRequired402 + +-- | Forbidden 403 response +forbidden403 :: Set h Status Response => h () (Linked '[Status] Response) +forbidden403 = mkResponse HTTP.forbidden403 + +-- | Not Found 404 response +notFound404 :: Set h Status Response => h () (Linked '[Status] Response) +notFound404 = mkResponse HTTP.notFound404 + +-- | Method Not Allowed 405 response +methodNotAllowed405 :: Set h Status Response => h () (Linked '[Status] Response) +methodNotAllowed405 = mkResponse HTTP.methodNotAllowed405 + +-- | Not Acceptable 406 response +notAcceptable406 :: Set h Status Response => h () (Linked '[Status] Response) +notAcceptable406 = mkResponse HTTP.notAcceptable406 + +-- | Proxy Authentication Required 407 response +proxyAuthenticationRequired407 :: Set h Status Response => h () (Linked '[Status] Response) +proxyAuthenticationRequired407 = mkResponse HTTP.proxyAuthenticationRequired407 + +-- | Request Timeout 408 response +requestTimeout408 :: Set h Status Response => h () (Linked '[Status] Response) +requestTimeout408 = mkResponse HTTP.requestTimeout408 + +-- | Conflict 409 response +conflict409 :: Set h Status Response => h () (Linked '[Status] Response) +conflict409 = mkResponse HTTP.conflict409 + +-- | Gone 410 response +gone410 :: Set h Status Response => h () (Linked '[Status] Response) +gone410 = mkResponse HTTP.gone410 + +-- | Length Required 411 response +lengthRequired411 :: Set h Status Response => h () (Linked '[Status] Response) +lengthRequired411 = mkResponse HTTP.lengthRequired411 + +-- | Precondition Failed 412 response +preconditionFailed412 :: Set h Status Response => h () (Linked '[Status] Response) +preconditionFailed412 = mkResponse HTTP.preconditionFailed412 + +-- | Request Entity Too Large 413 response +requestEntityTooLarge413 :: Set h Status Response => h () (Linked '[Status] Response) +requestEntityTooLarge413 = mkResponse HTTP.requestEntityTooLarge413 + +-- | Request URI Too Long 414 response +requestURITooLong414 :: Set h Status Response => h () (Linked '[Status] Response) +requestURITooLong414 = mkResponse HTTP.requestURITooLong414 + +-- | Unsupported Media Type 415 response +unsupportedMediaType415 :: Set h Status Response => h () (Linked '[Status] Response) +unsupportedMediaType415 = mkResponse HTTP.unsupportedMediaType415 + +-- | Requested Range Not Satisfiable 416 response +requestedRangeNotSatisfiable416 :: Set h Status Response => h () (Linked '[Status] Response) +requestedRangeNotSatisfiable416 = mkResponse HTTP.requestedRangeNotSatisfiable416 + +-- | Expectation Failed 417 response +expectationFailed417 :: Set h Status Response => h () (Linked '[Status] Response) +expectationFailed417 = mkResponse HTTP.expectationFailed417 + +-- | I'm A Teapot 418 response +imATeapot418 :: Set h Status Response => h () (Linked '[Status] Response) +imATeapot418 = mkResponse HTTP.imATeapot418 + +-- | Unprocessable Entity 422 response +unprocessableEntity422 :: Set h Status Response => h () (Linked '[Status] Response) +unprocessableEntity422 = mkResponse HTTP.unprocessableEntity422 + +-- | Precondition Required 428 response +preconditionRequired428 :: Set h Status Response => h () (Linked '[Status] Response) +preconditionRequired428 = mkResponse HTTP.preconditionRequired428 + +-- | Too Many Requests 429 response +tooManyRequests429 :: Set h Status Response => h () (Linked '[Status] Response) +tooManyRequests429 = mkResponse HTTP.tooManyRequests429 + +-- | Request Header Fields Too Large 431 response +requestHeaderFieldsTooLarge431 :: Set h Status Response => h () (Linked '[Status] Response) +requestHeaderFieldsTooLarge431 = mkResponse HTTP.requestHeaderFieldsTooLarge431 + +-- | Internal Server Error 500 response +internalServerError500 :: Set h Status Response => h () (Linked '[Status] Response) +internalServerError500 = mkResponse HTTP.internalServerError500 + +-- | Not Implemented 501 response +notImplemented501 :: Set h Status Response => h () (Linked '[Status] Response) +notImplemented501 = mkResponse HTTP.notImplemented501 + +-- | Bad Gateway 502 response +badGateway502 :: Set h Status Response => h () (Linked '[Status] Response) +badGateway502 = mkResponse HTTP.badGateway502 + +-- | Service Unavailable 503 response +serviceUnavailable503 :: Set h Status Response => h () (Linked '[Status] Response) +serviceUnavailable503 = mkResponse HTTP.serviceUnavailable503 + +-- | Gateway Timeout 504 response +gatewayTimeout504 :: Set h Status Response => h () (Linked '[Status] Response) +gatewayTimeout504 = mkResponse HTTP.gatewayTimeout504 + +-- | HTTP Version Not Supported 505 response +httpVersionNotSupported505 :: Set h Status Response => h () (Linked '[Status] Response) +httpVersionNotSupported505 = mkResponse HTTP.httpVersionNotSupported505 + +-- | Network Authentication Required 511 response +networkAuthenticationRequired511 :: Set h Status Response => h () (Linked '[Status] Response) +networkAuthenticationRequired511 = mkResponse HTTP.networkAuthenticationRequired511 diff --git a/src/WebGear/Core/Traits.hs b/src/WebGear/Core/Traits.hs new file mode 100644 --- /dev/null +++ b/src/WebGear/Core/Traits.hs @@ -0,0 +1,43 @@ +-- | All the traits supported by WebGear. +module WebGear.Core.Traits ( + module WebGear.Core.Trait.Auth.Basic, + module WebGear.Core.Trait.Auth.JWT, + module WebGear.Core.Trait.Auth.Common, + module WebGear.Core.Trait.Body, + module WebGear.Core.Trait.Header, + module WebGear.Core.Trait.Method, + module WebGear.Core.Trait.Path, + module WebGear.Core.Trait.QueryParam, + module WebGear.Core.Trait.Status, + StdHandler, +) where + +import WebGear.Core.Handler (Handler) +import WebGear.Core.Request (Request) +import WebGear.Core.Response (Response) +import WebGear.Core.Trait (Gets, Sets) +import WebGear.Core.Trait.Auth.Basic +import WebGear.Core.Trait.Auth.Common +import WebGear.Core.Trait.Auth.JWT +import WebGear.Core.Trait.Body +import WebGear.Core.Trait.Header +import WebGear.Core.Trait.Method +import WebGear.Core.Trait.Path +import WebGear.Core.Trait.QueryParam +import WebGear.Core.Trait.Status + +{- | Constraints that include all common traits. + + The type variables are: + + * @h@ - The handler arrow + * @m@ - The underlying monad of the handler + * @req@ - List of traits the handler `Gets` from the request + * @res@ - List of traits the handler `Sets` on the response +-} +type StdHandler h m req res = + ( Handler h m + , Gets h [Method, Path, PathEnd] Request + , Gets h req Request + , Sets h (Status : res) Response + ) diff --git a/webgear-core.cabal b/webgear-core.cabal new file mode 100644 --- /dev/null +++ b/webgear-core.cabal @@ -0,0 +1,108 @@ +cabal-version: 2.4 + +name: webgear-core +version: 1.0.0 +synopsis: Composable, type-safe library to build HTTP APIs +description: + WebGear is a library to for building composable, type-safe HTTP APIs. + See the documentation of WebGear.Core module to get started. +homepage: https://github.com/haskell-webgear/webgear-core#readme +bug-reports: https://github.com/haskell-webgear/webgear-core/issues +author: Raghu Kaippully +maintainer: rkaippully@gmail.com +copyright: 2020-2021 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/haskell-webgear/webgear-core + + +common webgear-common + default-language: Haskell2010 + 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: base >=4.13.0.0 && <4.17 + , bytestring >=0.10.10.1 && <0.12 + , case-insensitive ==1.2.* + , filepath ==1.4.* + , http-api-data ==0.4.* + , http-media ==0.8.* + , http-types ==0.12.* + , network ==3.1.* + , safe-exceptions ==0.1.* + , tagged ==0.8.* + , template-haskell >=2.15.0.0 && <2.19 + , text ==1.2.* + , unordered-containers ==0.2.* + , wai ==3.2.* + 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.10) + ghc-options: -Wunused-packages + +library + import: webgear-common + exposed-modules: WebGear.Core + , WebGear.Core.Modifiers + , WebGear.Core.Trait + , WebGear.Core.Request + , WebGear.Core.Response + , WebGear.Core.Handler + , WebGear.Core.Traits + , WebGear.Core.Trait.Auth.Basic + , WebGear.Core.Trait.Auth.JWT + , WebGear.Core.Trait.Auth.Common + , WebGear.Core.Trait.Body + , WebGear.Core.Trait.Header + , WebGear.Core.Trait.Method + , WebGear.Core.Trait.Path + , WebGear.Core.Trait.QueryParam + , WebGear.Core.Trait.Status + , WebGear.Core.Handler.Static + hs-source-dirs: src + build-depends: arrows ==0.4.* + , jose >=0.8.3.1 && <0.10 + , mime-types ==0.1.*