diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Changelog for simple-routing-core
+
+## 0.1.0.0
+
+* First implementation
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,67 @@
+# purescheme-wai-routing-core
+[](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")] "Hellow World!
"
+
+```
+
+## 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!
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Logic.hs b/app/Logic.hs
new file mode 100644
--- /dev/null
+++ b/app/Logic.hs
@@ -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
+ )
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -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")] "Hellow World!
"
+
+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
+
+-}
diff --git a/purescheme-wai-routing-core.cabal b/purescheme-wai-routing-core.cabal
new file mode 100644
--- /dev/null
+++ b/purescheme-wai-routing-core.cabal
@@ -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
+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
diff --git a/src/Network/Wai/Routing/Purescheme/Core.hs b/src/Network/Wai/Routing/Purescheme/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core.hs
@@ -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
+-- 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")] "Hellow World!
"
+--
+-- 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
+
+
+
+
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Basic.hs b/src/Network/Wai/Routing/Purescheme/Core/Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Basic.hs
@@ -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
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Entity.hs b/src/Network/Wai/Routing/Purescheme/Core/Entity.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Entity.hs
@@ -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
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Entity/Json.hs b/src/Network/Wai/Routing/Purescheme/Core/Entity/Json.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Entity/Json.hs
@@ -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 = []
+ }
+
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Internal.hs b/src/Network/Wai/Routing/Purescheme/Core/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Internal.hs
@@ -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 = []
+ }
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Method.hs b/src/Network/Wai/Routing/Purescheme/Core/Method.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Method.hs
@@ -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 = []
+ }
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Path.hs b/src/Network/Wai/Routing/Purescheme/Core/Path.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Path.hs
@@ -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
+
diff --git a/src/Network/Wai/Routing/Purescheme/Core/Query.hs b/src/Network/Wai/Routing/Purescheme/Core/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Wai/Routing/Purescheme/Core/Query.hs
@@ -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 = []
+ }
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"