packages feed

purescheme-wai-routing-core (empty) → 0.1.0.0

raw patch · 16 files changed

+1402/−0 lines, 16 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, http-media, http-types, interpolate, placeholders, purescheme-wai-routing-core, text, wai, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for simple-routing-core++## 0.1.0.0++* First implementation
+ LICENSE view
@@ -0,0 +1,176 @@+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS
+ README.md view
@@ -0,0 +1,67 @@+# purescheme-wai-routing-core+[![Build Status](https://travis-ci.org/purescheme/purescheme-wai-routing-core.svg?branch=master)](https://travis-ci.org/purescheme/purescheme-wai-routing-core)++*The goal of purescheme is make a simple framework for building fast microservices in haskell.*++This module provides simple routing functions for create rest APIs on top of a WAI server.++## Getting Started++Minimal Example to run a helloworld using Warp server:++```haskell+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Network.Wai.Routing.Purescheme.Core++import Network.HTTP.Types (status200, StdMethod(..), hContentType)+import Network.Wai.Handler.Warp (run)+import Network.Wai (responseLBS, Application)++main :: IO ()+main = run 8080 api++api :: Application+api = path "hello"+            $ method GET+            $ complete+            $ responseLBS status200 [(hContentType, "text/html")] "<h1>Hellow World!</h1>"++```++## Overview++This module provides simple routing functions that works on top of "Network.Wai"+applications.+ +The basic idea is provides functions that modifies an @"Application" in order to match+certain rules. It is inspired on akka http server Routing DSL.++## User Guide++The API is divided in several modules by its functionality:+- `Network.Wai.Routing.Purescheme.Core.Basic` provides the basic types and functionality including how to complete a request and exception handling.+- `Network.Wai.Routing.Purescheme.Core.Path` routing functions that matches with the Path of the URI.+- `Network.Wai.Routing.Purescheme.Core.Query` routing functions to extract parameters from the query part of the URI.+- `Network.Wai.Routing.Purescheme.Core.Method` routing functions based on http method.+- `Network.Wai.Routing.Purescheme.Core.Entity` routing and manipulation API related with Entity in the request and the response. Useful for content negotiation and serialization of entities.+- `Network.Wai.Routing.Purescheme.Core.Entity.Json` concrete functions to operate on JSON encoding entities based on Aeson library.++A complete example can be found in the [app](https://github.com/purescheme/purescheme-wai-routing-core/tree/master/app) folder.++## Why+There are many routing frameworks for Haskell but they usually are:+- They come with their own Monads or exoteric strategics to build routes.+- Some of them are not using the type system properly++So, as Haskell is totally functional, and, based on the simplicity of an Wai `Application` (which is basically+a function that converts requests to responses, why not create functions on top of Wai `Application` that +provides a functional way to implement RESTful APIs?++## Status+Currently the API is totally functionalm but the status is considered Alpha. That means, the whole API can change+in further release until we reach the beta status.++## Feedback are welcome!+Please, if you feel that some functionallity is missing or something can be improve, post a issue!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Logic.hs view
@@ -0,0 +1,93 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}+module Logic where++import Prelude hiding (id)+import Data.Aeson+import Data.IORef (IORef, readIORef, newIORef, atomicModifyIORef')+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import GHC.Generics++type Context = IORef [Pet]++data Pet = +  Pet+  { id :: Int+  , name :: Text+  , tag :: Text+  } deriving (Generic, Show)++instance ToJSON Pet+instance FromJSON Pet++data OffsetPagination = +  OffsetPagination+  { limit :: Maybe Int+  , page :: Maybe Int+  }+  +data ListResult a = ListResult+  { resultList :: [a]+  , page :: Int+  , totalPages :: Int+  , itemsPerPage :: Int+  , itemsTotal :: Int+  }++-- Model/DAO Methods+initialContext :: IO (IORef [Pet])+initialContext = newIORef +  [ Pet 1 "scooby" "no-tag"+  , Pet 2 "canelo" "dog"+  ]++defaultLimit :: Int+defaultLimit = 10++listPets :: Context -> OffsetPagination -> IO (ListResult Pet)+listPets context OffsetPagination{..} = do+  let actualLimit = fromMaybe defaultLimit limit+  let actualPage = fromMaybe 1 page+  pets <- readIORef context+  return ListResult+    { resultList = take actualLimit $ drop ((actualPage - 1) * actualLimit) pets+    , page = actualPage+    , totalPages = ((length pets) `div` actualLimit) + if (length pets) `mod` actualLimit == 0 then 0 else 1+    , itemsPerPage = actualLimit+    , itemsTotal = length pets+    }++getPet :: Context -> Int -> IO (Maybe Pet)+getPet context petId = do+  pets <- readIORef context+  return $ find (\pet -> id pet == petId) pets++createOrReplacePet :: Context -> Pet -> IO Bool+createOrReplacePet context newPet = atomicModifyIORef' context doIt+  where+    doIt pets = +      ( newPet:(filter (\pet -> id pet /= id newPet) pets)+      , all (\pet -> id pet /= id newPet) pets+      )
+ app/Main.hs view
@@ -0,0 +1,220 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Logic++import Network.Wai.Routing.Purescheme.Core++import Prelude hiding (id)+import Data.Aeson+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (ByteString)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import GHC.Generics+import Network.HTTP.Types (status200, StdMethod(..), Header, hContentType, statusCode)+import Network.Wai.Handler.Warp (run)+import Network.Wai (responseLBS, Response, Request, Application)++data ErrorResponse =+  ErrorResponse+  { code :: Int+  , message :: Text+  } deriving (Generic, Show)++instance ToJSON ErrorResponse++main :: IO ()+main = do+  context <- initialContext+  run 8080 $ api context++-- The API++api :: Context -> Application+api context = handleException handleRejections $ alternatives [restApiV1, v1 context]+  +handleRejections :: Rejection -> Application+handleRejections Rejection{..} = +  withContentNegotiationJson $ \negotiate ->+    complete $ negotiate $ entityResponse status headers $ ErrorResponse (statusCode status) message++-- Simple Api+restApiV1 :: Application+restApiV1 = path "hello"+            $ method GET+            $ complete+            $ responseLBS status200 [(hContentType, "text/html")] "<h1>Hellow World!</h1>"++v1 :: Context -> Application+v1 context =   +  pathSegment "v1" $ alternatives +    [ pathSegment "pets" $ alternatives +      [ pathEnd $ method GET $ listPetsEndpointV1 context+      , pathVar $ \petId -> pathEnd $ alternatives +        [ method GET $ showPetByIdEndpointV1 context petId+        , method PUT $ createOrUpdatePetEndpointV1 context petId+        ]+      ]+    ]++listPetsEndpointV1 :: Context -> GenericApplication Response+listPetsEndpointV1 context = +  withContentNegotiationJson $ \negotiate ->+    mapResponse negotiate $+      withOffsetPagination $ \pagination -> +        completeIO $ ok <$> listPets context pagination++showPetByIdEndpointV1 :: Context -> Int -> GenericApplication Response+showPetByIdEndpointV1 context petId =+  withContentNegotiationJson $ \negotiate -> completeIO $ do+    maybePet <- getPet context petId+    return $ case maybePet of+      Nothing -> negotiate $ notFound $ ErrorResponse 404 "Pet nof found"+      Just pet -> negotiate $ ok pet++createOrUpdatePetEndpointV1 :: Context -> Int -> GenericApplication Response+createOrUpdatePetEndpointV1 context petId =+  entityJson $ \pet ->+    withContentNegotiationJson $ \negotiate -> completeIO $+      if petId /= id pet+        then return $ negotiate $ badRequest $ ErrorResponse 400 "Pet id does not match with the URL"+        else do+          isNew <- createOrReplacePet context pet+          if isNew+            then return $ negotiate $ created pet+            else return $ negotiate $ ok pet++-- Common abstraction for offset based pagination++withOffsetPagination :: (OffsetPagination -> GenericApplication (EntityResponse (ListResult a))) -> GenericApplication (EntityResponse [a])+withOffsetPagination f = +  maybeSingleParameter "limit" $ \mLimit -> +  maybeSingleParameter "page" $ \mPage ->+    withRequest $ \req ->  +      mapResponse (transformResponse req) $ f $ OffsetPagination { limit = mLimit, page = mPage }++  where++      transformResponse :: Request -> EntityResponse (ListResult a) -> EntityResponse [a]+      transformResponse req resp = mapResponseHeaders insertLinkHeader $ mapEntity resultList resp+      +        where++          listResult = entity resp++          insertLinkHeader :: [Header] -> [Header]+          insertLinkHeader headers = ("link", linkHeaderValue):filter (\(k, _) -> k /= "link" ) headers++          linkHeaderValue :: BS.ByteString+          linkHeaderValue = BS.intercalate "," $ catMaybes [nextHeader, lastHeader, firstHeader, prevHeader]++          -- TODO Make Link headers+          nextHeader = Nothing+          lastHeader = Nothing+          firstHeader = Nothing+          prevHeader = Nothing++{- +-- XmlAndJson Support++-- V2 Api:+-- Supports JSON and XML++v2 :: Context -> Application+v2 context = +  pathSegment "v2" $ alternatives +    [ pathSegment "pets" $ alternatives +      [ pathEnd $ method GET $ listPetsEndpointV1 context+      , pathVar $ \petId -> pathEnd $ alternatives+        [ method GET $ showPetByIdEndpointV1 context petId+        , method PUT $ createOrUpdatePetEndpointV1 context petId+        ]+      ]+    ]++listPetsEndpointV2 :: Context -> GenericApplication Response+listPetsEndpointV2 context = +  withXmlAndJson $ \negotiate ->+    mapResponse negotiate $+      withOffsetPagination $ \pagination -> +        completeIO $ ok <$> listPets context pagination++showPetByIdEndpointV2 :: Context -> Int -> GenericApplication Response+showPetByIdEndpointV2 context petId =+  withXmlAndJson $ \negotiate -> completeIO $ do+    maybePet <- getPet context petId+    return $ case maybePet of+      Nothing -> negotiate $ notFound $ ErrorResponse 404 "Pet nof found"+      Just pet -> negotiate $ ok pet++createOrUpdatePetEndpointV2 :: Context -> Int -> GenericApplication Response+createOrUpdatePetEndpointV2 context petId =+  requestEntity jsonOrXml $ \pet ->+    withXmlAndJson $ \negotiate -> completeIO $+      if petId /= id pet+        then return $ negotiate $ badRequest $ ErrorResponse 400 "Pet id does not match with the URL"+        else do+          isNew <- createOrReplacePet context pet+          if isNew+            then return $ negotiate $ created pet+            else return $ negotiate $ ok pet++jsonOrXml :: (FromJSON a, FromXML a) => [(BS.ByteString, ByteString -> Either String a)]+jsonOrXml = +  [ ("application/json", eitherDecode)+  , ("application/xml", fromXML)+  ]++++withXmlAndJson :: ((forall a. (ToJSON a, ToXML a) => EntityResponse a -> NegotiatedResponse) -> GenericApplication NegotiatedResponse) -> GenericApplication Response+withXmlAndJson f =+  withCustomNegotiation $ f $ negotiated negotiationXmlAndJson++negotiationXmlAndJson :: (ToJSON a, ToXML a) => [(BS.ByteString, a -> ByteString)]+negotiationXmlAndJson = +  [ ("application/json", encode)+  , ("application/xml", toXML)+  ]++class FromXML a where+  fromXML :: ByteString -> Either String a++instance FromXML Pet where+  fromXML bs = $notImplemented++class ToXML a where+  toXML :: a -> ByteString++instance ToXML a => ToXML [a] where+  toXML a = $notImplemented++instance ToXML Pet where+  toXML a = $notImplemented++instance ToXML ErrorResponse where+  toXML a = $notImplemented++-}
+ purescheme-wai-routing-core.cabal view
@@ -0,0 +1,100 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 62443a31064cb1b5d185060c9e61a90dfa3f438fa8bdae8a2ab8a84699adf924++name:           purescheme-wai-routing-core+version:        0.1.0.0+synopsis:       Simple Routing functions for Wai Applications+description:    Please see the README on GitHub at <https://github.com/purescheme/purescheme-wai-routing-core#readme>+category:       Web+homepage:       https://github.com/purescheme/purescheme-wai-routing-core#readme+bug-reports:    https://github.com/purescheme/purescheme-wai-routing-core/issues+author:         Fernando Rincon Martin+maintainer:     f.rincon@protonmail.com+copyright:      2020 Fernando Rincon Martin+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/purescheme/purescheme-wai-routing-core++flag development+  description: Used while development+  manual: True+  default: False++library+  exposed-modules:+      Network.Wai.Routing.Purescheme.Core+      Network.Wai.Routing.Purescheme.Core.Basic+      Network.Wai.Routing.Purescheme.Core.Entity+      Network.Wai.Routing.Purescheme.Core.Entity.Json+      Network.Wai.Routing.Purescheme.Core.Internal+      Network.Wai.Routing.Purescheme.Core.Method+      Network.Wai.Routing.Purescheme.Core.Path+      Network.Wai.Routing.Purescheme.Core.Query+  other-modules:+      Paths_purescheme_wai_routing_core+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , http-media+    , http-types+    , interpolate+    , text+    , wai+  if flag(development)+    build-depends:+        placeholders+  default-language: Haskell2010++executable simple-routing-core-exe+  main-is: Main.hs+  other-modules:+      Logic+      Paths_purescheme_wai_routing_core+  hs-source-dirs:+      app+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , http-types+    , purescheme-wai-routing-core+    , text+    , wai+    , warp+  if flag(development)+    build-depends:+        placeholders+  default-language: Haskell2010++test-suite simple-routing-core-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_purescheme_wai_routing_core+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , purescheme-wai-routing-core+  if flag(development)+    build-depends:+        placeholders+  default-language: Haskell2010
+ src/Network/Wai/Routing/Purescheme/Core.hs view
@@ -0,0 +1,105 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+-- |+-- Module     : Network.Wai.Routing.Purescheme.Core+-- Copyright  : (c) Fernando Rincon Martin 2020+-- License    : Apache-2.0 (see the file LICENSE)+-- +-- Maintainer : Fernando Rincon Martin <f.rincon@protonmail.com>+-- Stability: alpha+-- +-- This module provides simple routing functions that works on top of "Network.Wai" +-- applications.+-- +-- The basic idea is provides functions that modifies an @"Application" in order to match+-- certain rules. It is inspired on akka http server DSL.+--+-- A simple example of a Json rest api:+-- +-- >   restApi :: Application+-- >   restApi = path "hello" +-- >               $ method GET +-- >               $ complete +-- >               $ responseLBS status200 [(hContentType, "text/html")] "<h1>Hellow World!</h1>"+-- +-- As the result is a Wai @'Application' we can run it directly with warp server:+--+-- >   main :: IO ()+-- >   main = run 8080 restApi+--+-- The api is in alpha state, so that the api can change in any new release. It is very welcome +-- suggestions and comments.++module Network.Wai.Routing.Purescheme.Core ( +  -- * Basic functionality+  -- ** Basic Types and Classes+    GenericApplication+  , Rejection(..)+  , FromUri(..)+  , HasResponseHeaders(..)+  -- ** Basic combinators+  , alternatives+  -- ** Exception handling+  , handleException+  , withDefaultExceptionHandler+  -- ** Complete or reject requests+  , complete+  , completeIO+  -- ** Response Manipulatins+  , mapResponse+  -- ** Requests functions+  , withRequest+  -- * Uri path functions+  , path+  , pathSegment+  , pathVar+  , pathEnd+  -- * Query string functions+  , singleParameter+  , maybeSingleParameter+  -- * Http method +  , method+  -- * Entity based+  -- ** Entity Based types+  , EntityResponse+  , entity+  , NegotiatedResponse+  -- ** Basic entity functions+  , mapEntity+  , withCustomNegotiation+  , withCustomNegotiation'+  , negotiated+  , requestEntity+  , ok+  , created+  , notFound+  , badRequest+  , entityResponse+  -- ** Json based entity functions+  , withContentNegotiationJson+  , entityJson+)+where++import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Path+import Network.Wai.Routing.Purescheme.Core.Query+import Network.Wai.Routing.Purescheme.Core.Method+import Network.Wai.Routing.Purescheme.Core.Entity+import Network.Wai.Routing.Purescheme.Core.Entity.Json++++
+ src/Network/Wai/Routing/Purescheme/Core/Basic.hs view
@@ -0,0 +1,133 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Routing.Purescheme.Core.Basic+  ( GenericApplication+  , Rejection(..)+  , FromUri(..)+  , HasResponseHeaders(..)+  , alternatives+  , handleException+  , withDefaultExceptionHandler+  , complete+  , completeIO+  , mapResponse+  , withRequest+  )+where++import Network.Wai.Routing.Purescheme.Core.Internal++import Control.Exception (Exception, catch)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int32, Int64)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import Network.HTTP.Types (ResponseHeaders, hContentType)+import Network.Wai (Response, ResponseReceived, Request, responseLBS)+import qualified Network.Wai as Wai++-- | Abstraction of Wai @'Application' on the type of response+type GenericApplication r = Request -> (r -> IO ResponseReceived) -> IO ResponseReceived++-- | Class of types that can be converted from the uri+class FromUri a where+  fromText :: T.Text -> a+  fromByteString :: ByteString -> a+  fromByteString = fromText . T.decodeUtf8++instance FromUri T.Text where+  fromText = id++instance FromUri Bool where+  fromText p = read $ T.unpack p++instance FromUri Int where+  fromText p = read $ T.unpack p++instance FromUri Int32 where+  fromText p = read $ T.unpack p++instance FromUri Int64 where+  fromText p = read $ T.unpack p++instance FromUri LT.Text where+  fromText = LT.fromStrict++-- | Class which instaances contains response heaaders+class HasResponseHeaders a where+  mapResponseHeaders :: (ResponseHeaders -> ResponseHeaders) -> a -> a++instance HasResponseHeaders Response where+  mapResponseHeaders = Wai.mapResponseHeaders++-- | Combines multiple generic applications in one+-- This function will try every application for each request, and return the first+-- response that does not fail+--+-- In case of rejections (Reection thrown), it will rethrown the first+-- exception with higher priority+alternatives :: [GenericApplication r] -> GenericApplication r+alternatives = alternatives' notFoundDefaultRejection+  where+    alternatives' :: Rejection -> [GenericApplication r] -> GenericApplication r+    alternatives' rejection [] _ _ = reject' rejection+    alternatives' rejection (x:xs) req respond =+      x req respond `catch` \e -> alternatives' (chooseRejection rejection e) xs req respond++    chooseRejection r1 r2 = +      if priority r1 < priority r2+        then r2+        else r1++-- Exception Handler functions++-- | Capture exceptions and convert to generic applications+handleException :: Exception e => (e -> GenericApplication a) -> GenericApplication a -> GenericApplication a+handleException exceptionFunc innerApp req resp = +  catch (innerApp req resp) (\e -> exceptionFunc e req resp)++-- | By default capture all @'Rejection' and convert them in specific responses+-- the content type returned is 'text/plain" and the body will contain the error message+withDefaultExceptionHandler :: GenericApplication Response -> GenericApplication Response+withDefaultExceptionHandler = handleException handleRejection+  where+    handleRejection :: Rejection -> GenericApplication Response+    handleRejection Rejection{status, message} _ respond = +      respond $ responseLBS status [(hContentType, "text/plain")] (LBS.fromStrict $ T.encodeUtf8 message)++-- | Ends the request responding with the argument+complete :: a -> GenericApplication a+complete response _ respond = respond response++-- | Ends the request excuting the provided IO and responding the result of the IO+completeIO :: IO a -> GenericApplication a+completeIO responseIO _ respond = do+  response <- responseIO+  respond response++-- | Maps a response type to another response type+mapResponse :: (a -> b) -> GenericApplication a -> GenericApplication b+mapResponse mapf inner req respond = inner req (respond . mapf)++-- | Pass the request to the provided function+withRequest :: (Request -> GenericApplication a) -> GenericApplication a+withRequest reqFun req = reqFun req req
+ src/Network/Wai/Routing/Purescheme/Core/Entity.hs view
@@ -0,0 +1,186 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Routing.Purescheme.Core.Entity+  ( EntityResponse+  , entity+  , NegotiatedResponse+  , mapEntity+  , withCustomNegotiation+  , withCustomNegotiation'+  , negotiated+  , ok+  , created+  , notFound+  , badRequest+  , entityResponse+  , requestEntity+  )+where++import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Internal++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as LBC+import qualified Data.ByteString.Lazy as LBS+import Data.List (find)+import Data.Maybe (fromJust, fromMaybe)+import Data.String.Interpolate.IsString (i)+import Network.HTTP.Media (matchAccept, mapAccept)+import Network.HTTP.Types (Status, ResponseHeaders, notAcceptable406, hAccept, hContentType, +  statusMessage, badRequest400, unsupportedMediaType415, ok200, created201, notFound404)+import Network.Wai (Response, ResponseReceived, responseLBS, requestHeaders, strictRequestBody)++data EntityResponse e = EntityResponse Status ResponseHeaders e++data NegotiatedResponse = NegotiatedResponse Status ResponseHeaders [(ByteString, LBS.ByteString)]++instance HasResponseHeaders (EntityResponse a) where+  mapResponseHeaders mapf (EntityResponse responseStatus responseHeaders entity) = +    EntityResponse responseStatus (mapf responseHeaders) entity++instance HasResponseHeaders (NegotiatedResponse) where+  mapResponseHeaders mapf (NegotiatedResponse negotiatedStatus negotiatedHeaders entity) = +    NegotiatedResponse negotiatedStatus (mapf negotiatedHeaders) entity++-- | Entity Accessor+entity :: EntityResponse e -> e+entity (EntityResponse _ _ e) = e++-- | Maps a entity response+mapEntity :: (a -> b) -> EntityResponse a -> EntityResponse b+mapEntity mapf (EntityResponse responseStatus responseHeaders entity) = +  EntityResponse responseStatus responseHeaders (mapf entity) ++-- | Converts an application of NegotiatedResponse to a normal WAI Application+-- +-- This will reject the request with not acceptable (406) in case the content negotation+-- fail+-- +-- Note: This is going to do the content negotiation after the inner application has repond with +-- a NegotiatedResponse. That means, any IO is performed before the conetent negoatiation happen.+-- TODO: Find another way to do custom negotiation+-- Better to use @'withCustomNegotiation''+withCustomNegotiation :: GenericApplication NegotiatedResponse -> GenericApplication Response+withCustomNegotiation inner req respond = inner req processNegotiated+  where++    processNegotiated :: NegotiatedResponse -> IO ResponseReceived+    processNegotiated (NegotiatedResponse responseStatus responseHeaders responses) =+      let+        acceptedMediaTypes = fmap fst responses+        respondUsing (mediaType, payload) = +          let+            newHeaders = addOrReplaceHeader responseHeaders (hContentType, mediaType)+            response = responseLBS responseStatus newHeaders payload+          in respond response+      in+        case lookup hAccept $ requestHeaders req of+          Nothing -> respondUsing $ head responses+          Just "*/*" -> respondUsing $ head responses+          Just accept -> case matchAccept acceptedMediaTypes accept of+            Nothing -> reject' $ notAcceptableRejection acceptedMediaTypes+            Just accepted -> respondUsing $ fromJust $ find (\(k, _) -> k == accepted) responses++-- | The same than @'withCustomNegotiation' but checking the Accept header before doing any IO+withCustomNegotiation' :: [ByteString] -> GenericApplication NegotiatedResponse -> GenericApplication Response+withCustomNegotiation' accepted inner req = +  let+    doit = withCustomNegotiation inner req+  in+    case lookup hAccept $ requestHeaders req of +      Nothing -> doit+      Just "*/*" -> doit+      Just accept -> case matchAccept accepted accept of+        Nothing -> reject $ notAcceptableRejection accepted+        Just _ -> doit++notAcceptableRejection :: [ByteString] -> Rejection+notAcceptableRejection acceptedResponses = +  Rejection+    { status = notAcceptable406+    , message = [i|#{statusMessage notAcceptable406}: Acceptable media types: #{LBC.intercalate ", " acceptedResponses}|]+    , priority = 200+    , headers = []+    }++-- | Converts a entity response to a negotiated entity+negotiated :: [(ByteString, a -> LBS.ByteString)] -> EntityResponse a ->  NegotiatedResponse+negotiated accptableResponses (EntityResponse responseStatus responseHeaders entity) = +  NegotiatedResponse responseStatus responseHeaders (fmap (\(key, v) -> (key, v entity)) accptableResponses)+  -- TODO: This uses lazyness from haskell so that not all payloads are generated++-- | Reads the entity and pass it to provided function+--+-- The map provides the accepted media types with the functions that decodes it+-- +-- As specified in https://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1+-- a missing content type header from the request is treated "application/octet-stream"+--+-- Note: This will read all the payload in memory and then decode it+-- so it can blow up the memory. Better to have a guard on the size of the request+requestEntity :: [(ByteString, LBS.ByteString -> Either String a)] -> (a -> GenericApplication b) -> GenericApplication b+requestEntity mappings fa req respond = +  let +    contentTypeHeader = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders req+  in+    case mapAccept mappings contentTypeHeader of+      Just decodeFunc -> do+        decodedOrError <- decodeFunc <$> strictRequestBody req+        case decodedOrError of+          Left decodeError -> reject' $ decodeErrorRejection decodeError+          Right decoded -> fa decoded req respond+      Nothing -> reject' $ unsupportedMediaTypeRejection $ fmap fst mappings++decodeErrorRejection :: String -> Rejection+decodeErrorRejection reason = +  Rejection+    { status = badRequest400+    , message = [i|#{statusMessage badRequest400}: Error reading entity: #{reason}|]+    , priority = 200+    , headers = []+    }++unsupportedMediaTypeRejection :: [ByteString] -> Rejection+unsupportedMediaTypeRejection supportedMediaTypes = +  Rejection+    { status = unsupportedMediaType415+    , message = [i|#{statusMessage unsupportedMediaType415}: Supported Media Types: #{LBC.intercalate ", " supportedMediaTypes}|]+    , priority = 200+    , headers = []+    }++-- | Creates an entity response with status 200+ok :: a -> EntityResponse a+ok = EntityResponse ok200 []++-- | Creates a entity response with status 201+created :: a -> EntityResponse a+created = EntityResponse created201 []++-- | Creates an entity response with status 404+notFound :: a -> EntityResponse a+notFound = EntityResponse notFound404 []++-- | Creates an entity response with status 400+badRequest :: a -> EntityResponse a+badRequest = EntityResponse badRequest400 []++-- | Creates a entity response with the provided status and response headers+entityResponse :: Status -> ResponseHeaders -> a -> EntityResponse a+entityResponse = EntityResponse
+ src/Network/Wai/Routing/Purescheme/Core/Entity/Json.hs view
@@ -0,0 +1,84 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Routing.Purescheme.Core.Entity.Json+  ( withContentNegotiationJson+  , entityJson+  )+where++import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Entity+import Network.Wai.Routing.Purescheme.Core.Internal++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.String.Interpolate.IsString (i)+import qualified Data.Text as T+import Network.HTTP.Media (MediaType, matchContent)+import Network.HTTP.Types (unsupportedMediaType415, badRequest400, statusMessage, hContentType)+import Network.Wai (Response, strictRequestBody, requestHeaders)++import Data.Aeson (ToJSON, FromJSON, eitherDecode, encode)++withContentNegotiationJson :: ((forall a. ToJSON a => EntityResponse a -> NegotiatedResponse) -> GenericApplication NegotiatedResponse) -> GenericApplication Response+withContentNegotiationJson f = withCustomNegotiation $ f $ negotiated negotiationJson++negotiationJson :: ToJSON a => [(ByteString, a -> LBS.ByteString)]+negotiationJson = +  [ ("application/json", encode)+  ]+++-- TODO: We are doing strictRequestBody that means, we are going to read all the body in memory+-- so that we need to have a guard on the bytes of the content (Content-Length)+entityJson :: FromJSON a => (a -> GenericApplication b) -> GenericApplication b+entityJson inner req respond = +  if isValidContentType+    then do+      valueString <- strictRequestBody req+      case eitherDecode valueString of+        Right result -> inner result req respond+        Left decodeError -> reject' $ decodeErrorRejection $ T.pack decodeError+    else reject' $ unsupportedMediaTypeRejection "Content-Type not supported"+  where+    isValidContentType = +      case lookup hContentType $ requestHeaders req of +        Nothing -> True+        Just contentTypeHeader -> case matchContent ["application/json" :: MediaType] contentTypeHeader of+          Nothing -> False+          Just _ -> True++unsupportedMediaTypeRejection :: T.Text -> Rejection+unsupportedMediaTypeRejection errorMessage =+  Rejection+    { status = unsupportedMediaType415+    , message = [i|#{statusMessage unsupportedMediaType415}: #{errorMessage}|]+    , priority = 200+    , headers = []+    }++decodeErrorRejection :: T.Text -> Rejection+decodeErrorRejection errorMessage =+  Rejection+    { status = badRequest400+    , message = [i|#{statusMessage badRequest400}: Error decoding entity body: #{errorMessage}|]+    , priority = 300+    , headers = []+    }+
+ src/Network/Wai/Routing/Purescheme/Core/Internal.hs view
@@ -0,0 +1,60 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}+module Network.Wai.Routing.Purescheme.Core.Internal (+    Rejection(..)+  , reject+  , reject'+  , notFoundDefaultRejection+  , addOrReplaceHeader+) where++import Control.Exception (Exception, throwIO)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Typeable (Typeable)+import Network.Wai (ResponseReceived)+import Network.HTTP.Types (Status, ResponseHeaders, Header, notFound404, statusMessage)++data Rejection +  = Rejection+  { message :: Text+  , priority :: Int+  , status :: Status+  , headers :: ResponseHeaders+  } +  deriving (Show, Typeable)++instance Exception Rejection++reject :: Rejection -> (r -> IO ResponseReceived) -> IO ResponseReceived+reject rejectionException _ = reject' rejectionException++reject' :: Rejection -> IO ResponseReceived+reject' = throwIO++addOrReplaceHeader :: [Header] -> Header -> [Header]+addOrReplaceHeader fromHeaders header@(key, _) = +   header:filter (\(k, _) -> k /= key) fromHeaders++notFoundDefaultRejection :: Rejection+notFoundDefaultRejection = +  Rejection+    { status = notFound404+    , message = decodeUtf8 $ statusMessage notFound404+    , priority = minBound+    , headers = []+    }
+ src/Network/Wai/Routing/Purescheme/Core/Method.hs view
@@ -0,0 +1,43 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Routing.Purescheme.Core.Method+  ( method+  )+where++import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Internal++import qualified Data.Text.Encoding as T+import Network.HTTP.Types (StdMethod, renderStdMethod, methodNotAllowed405, statusMessage)+import Network.Wai (requestMethod)++-- | Match with standard http method+method :: StdMethod -> GenericApplication e -> GenericApplication e+method m f req =+  if requestMethod req == renderStdMethod m+    then f req+    else reject methodNotAllowedRejection++methodNotAllowedRejection :: Rejection+methodNotAllowedRejection =+  Rejection+    { status = methodNotAllowed405+    , message = T.decodeUtf8 $ statusMessage methodNotAllowed405+    , priority = 100+    , headers = []+    }
+ src/Network/Wai/Routing/Purescheme/Core/Path.hs view
@@ -0,0 +1,61 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Routing.Purescheme.Core.Path+  ( path+  , pathSegment+  , pathVar+  , pathEnd+  )+where++import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Internal++import Data.Text (Text, intercalate)+import Network.Wai (pathInfo)++-- | Match the remaining path+path :: Text -> GenericApplication r -> GenericApplication r+path p app req =+  if p == intercalate "/" (pathInfo req)+    then app $ req {pathInfo = []}+    else reject notFoundDefaultRejection++-- | Match the next path segment and remove from the request+pathSegment :: Text -> GenericApplication r -> GenericApplication r+pathSegment expectedSegment app req =+  case pathInfo req of+    (p:rest) | p == expectedSegment -> app $ req {pathInfo = rest}+    _ -> reject notFoundDefaultRejection++-- | Use the next path segment as a variable and remove from the request+pathVar :: FromUri a => (a -> GenericApplication r) -> GenericApplication r+pathVar f req = +  case pathInfo req of+    [] -> reject notFoundDefaultRejection+    [""] -> reject notFoundDefaultRejection+    (p:rest) -> f (fromText p) (req{pathInfo = rest})++-- | Match if all the path has been consumed or the remaining is a trailing slash+pathEnd :: GenericApplication r -> GenericApplication r+pathEnd f req = +  case pathInfo req of+    [] -> f req+    [""] -> f req{pathInfo = []}+    _ -> reject notFoundDefaultRejection+
+ src/Network/Wai/Routing/Purescheme/Core/Query.hs view
@@ -0,0 +1,65 @@+-- Copyright 2020 Fernando Rincon Martin+-- +-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+-- +--     http://www.apache.org/licenses/LICENSE-2.0+-- +-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-------------------------------------------------------------------------------+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Routing.Purescheme.Core.Query+  ( singleParameter+  , maybeSingleParameter+  )+where+  +import Network.Wai.Routing.Purescheme.Core.Basic+import Network.Wai.Routing.Purescheme.Core.Internal++import Data.ByteString (ByteString)+import qualified Data.Text as T+import Data.String.Interpolate.IsString (i)+import Network.HTTP.Types (badRequest400, statusMessage)+import Network.Wai (queryString)++-- | Match single parameter in the query string, fails when the parameter is not found or the+-- query string contains multiple values for the parameter+singleParameter :: FromUri a => ByteString -> (a -> GenericApplication b) -> GenericApplication b+singleParameter name f req =+  case filter (\(k, _) -> k == name) $ queryString req of+    [(_, Just value)] -> f (fromByteString value) req+    [] -> reject $ invalidParameterRejection [i|Required query parameter not found: #{name}|]+    _ -> reject $ invalidParameterRejection +      [i|Found more than one parameter in query string, required only one: #{name}|]++-- | Match single parameter in the query string, if multiple values for the same parameter found+-- then fails+maybeSingleParameter :: +  FromUri a +  => ByteString +  -> (Maybe a -> GenericApplication r) +  -> GenericApplication r+maybeSingleParameter name f req =+  case filter (\(k, _) -> k == name) $ queryString req of+    [(_, Just value)] -> f (Just $ fromByteString value) req+    [] -> f Nothing req+    _ -> +      reject $ invalidParameterRejection +        [i|Found more than one parameter in query string, required none or only one: #{name}|]++invalidParameterRejection :: T.Text -> Rejection+invalidParameterRejection errorMessage =+  Rejection+    { status = badRequest400+    , message = [i|#{statusMessage badRequest400}: #{errorMessage}|]+    , priority = 200+    , headers = []+    }+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"