├── stack.yaml ├── webgear-examples ├── README.md ├── realworld │ ├── .gitignore │ ├── ui │ │ ├── assets │ │ │ ├── vendor-d41d8cd98f00b204e9800998ecf8427e.css │ │ │ ├── ember-realworld-d41d8cd98f00b204e9800998ecf8427e.css │ │ │ └── ember.ico │ │ ├── README.md │ │ └── index.html │ ├── realworld.db │ ├── README.md │ ├── Model │ │ ├── Tag.hs │ │ ├── Common.hs │ │ ├── Entities.hs │ │ ├── Comment.hs │ │ ├── Profile.hs │ │ ├── User.hs │ │ └── Article.hs │ ├── API │ │ ├── Tag.hs │ │ ├── Profile.hs │ │ ├── Comment.hs │ │ ├── User.hs │ │ ├── Common.hs │ │ └── Article.hs │ ├── realworld.jwk │ └── Main.hs ├── hello │ └── Main.hs ├── webgear-examples.cabal └── users │ └── Main.hs ├── .gitignore ├── cabal.project ├── stack-8.6.5.yaml ├── stack-8.10.4.yaml ├── stack-8.8.4.yaml ├── webgear-benchmarks ├── user.json ├── README.md ├── src │ └── users │ │ ├── Scotty.hs │ │ ├── Model.hs │ │ ├── Servant.hs │ │ ├── Main.hs │ │ └── WebGear.hs ├── webgear-benchmarks.cabal └── results │ └── bench-ab-users.txt ├── stack.yaml.lock ├── stack-8.10.4.yaml.lock ├── stack-8.6.5.yaml.lock ├── stack-8.8.4.yaml.lock ├── webgear-server ├── src │ ├── WebGear │ │ ├── Modifiers.hs │ │ ├── Middlewares.hs │ │ ├── Util.hs │ │ ├── Handlers │ │ │ └── Static.hs │ │ ├── Middlewares │ │ │ ├── Auth │ │ │ │ ├── Util.hs │ │ │ │ ├── Basic.hs │ │ │ │ └── JWT.hs │ │ │ ├── Body.hs │ │ │ ├── Method.hs │ │ │ ├── Params.hs │ │ │ ├── Path.hs │ │ │ └── Header.hs │ │ ├── Trait.hs │ │ └── Types.hs │ └── WebGear.hs ├── test │ ├── Unit.hs │ ├── Main.hs │ ├── Unit │ │ └── Trait │ │ │ ├── Path.hs │ │ │ └── Header.hs │ ├── Properties.hs │ └── Properties │ │ └── Trait │ │ ├── Method.hs │ │ ├── Params.hs │ │ ├── Path.hs │ │ ├── Body.hs │ │ ├── Auth │ │ └── Basic.hs │ │ └── Header.hs ├── README.md ├── ChangeLog.md ├── .hlint.yaml └── webgear-server.cabal ├── README.md ├── .stylish-haskell.yaml ├── hie.yaml └── .github └── workflows └── ci.yaml /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-8.10.4.yaml -------------------------------------------------------------------------------- /webgear-examples/README.md: -------------------------------------------------------------------------------- 1 | # WebGear Examples 2 | -------------------------------------------------------------------------------- /webgear-examples/realworld/.gitignore: -------------------------------------------------------------------------------- 1 | realworld.db-shm 2 | realworld.db-wal -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .hie/ 3 | dist-newstyle/ 4 | cabal.project.freeze 5 | *~ -------------------------------------------------------------------------------- /webgear-examples/realworld/ui/assets/vendor-d41d8cd98f00b204e9800998ecf8427e.css: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /webgear-examples/realworld/ui/assets/ember-realworld-d41d8cd98f00b204e9800998ecf8427e.css: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: webgear-server/ 2 | webgear-examples/ 3 | webgear-benchmarks/ -------------------------------------------------------------------------------- /webgear-examples/realworld/realworld.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rkaippully/webgear/HEAD/webgear-examples/realworld/realworld.db -------------------------------------------------------------------------------- /stack-8.6.5.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | 3 | packages: 4 | - ./webgear-server 5 | - ./webgear-examples 6 | - ./webgear-benchmarks 7 | -------------------------------------------------------------------------------- /stack-8.10.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.15 2 | 3 | packages: 4 | - ./webgear-server 5 | - ./webgear-examples 6 | - ./webgear-benchmarks 7 | -------------------------------------------------------------------------------- /stack-8.8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | 3 | packages: 4 | - ./webgear-server 5 | - ./webgear-examples 6 | - ./webgear-benchmarks 7 | -------------------------------------------------------------------------------- /webgear-examples/realworld/ui/assets/ember.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rkaippully/webgear/HEAD/webgear-examples/realworld/ui/assets/ember.ico -------------------------------------------------------------------------------- /webgear-benchmarks/user.json: -------------------------------------------------------------------------------- 1 | {"userId": 1, "userName": "John Doe", "dateOfBirth": "2000-03-01", "gender": "Male", "emailAddress": "john@example.com"} 2 | -------------------------------------------------------------------------------- /webgear-examples/realworld/ui/README.md: -------------------------------------------------------------------------------- 1 | # ember-realworld 2 | This UI component is built from the ember-realworld app located at https://github.com/gothinkster/ember-realworld. 3 | Licensed under MIT license. 4 | -------------------------------------------------------------------------------- /webgear-examples/realworld/README.md: -------------------------------------------------------------------------------- 1 | # WebGear realworld 2 | A medium.com clone (called conduit) specified by https://github.com/gothinkster/realworld. 3 | 4 | Run with: 5 | 6 | ```shell 7 | cd webgear-examples/realworld 8 | stack exec realworld 9 | ``` 10 | 11 | This starts the app at http://localhost:3000/ 12 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Tag.hs: -------------------------------------------------------------------------------- 1 | module Model.Tag 2 | ( list 3 | ) where 4 | 5 | import Database.Esqueleto 6 | import Model.Common 7 | import Model.Entities 8 | import Relude 9 | 10 | 11 | list :: DBAction [Text] 12 | list = fmap unValue <$> 13 | -- select only tags used in articles 14 | (select $ from $ 15 | \(tag, articleTag) -> do 16 | where_ (tag ^. TagId ==. articleTag ^. ArticleTagTagid) 17 | pure $ tag ^. TagName) 18 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 567679 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/15.yaml 11 | sha256: 72e87841a0ab5b72f6f018e8ee692fd972b7bb32a944990f028e10d6eb528e63 12 | original: lts-17.15 13 | -------------------------------------------------------------------------------- /stack-8.10.4.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 567679 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/15.yaml 11 | sha256: 72e87841a0ab5b72f6f018e8ee692fd972b7bb32a944990f028e10d6eb528e63 12 | original: lts-17.15 13 | -------------------------------------------------------------------------------- /stack-8.6.5.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 524996 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml 11 | sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 12 | original: lts-14.27 13 | -------------------------------------------------------------------------------- /stack-8.8.4.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 534126 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml 11 | sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 12 | original: lts-16.31 13 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module API.Tag 4 | ( list 5 | ) where 6 | 7 | 8 | import API.Common 9 | import qualified Model.Tag as Model 10 | import Relude 11 | import WebGear 12 | 13 | 14 | list :: Handler' App req LByteString 15 | list = jsonResponseBody @(Wrapped "tags" [Text]) handler 16 | where 17 | handler = Kleisli $ \_request -> do 18 | tags <- runDBAction Model.list 19 | pure $ ok200 $ Wrapped tags 20 | -------------------------------------------------------------------------------- /webgear-examples/hello/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | import Network.HTTP.Types (StdMethod (GET)) 6 | import Network.Wai.Handler.Warp (run) 7 | import WebGear 8 | 9 | routes :: Handler '[] String 10 | routes = [route| GET /hello/name:String/ |] $ 11 | Kleisli $ \request -> do 12 | let name = pick @(PathVar "name" String) $ from request 13 | return $ ok200 $ "Hello, " ++ name 14 | 15 | main :: IO () 16 | main = run 3000 (toApplication routes) 17 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Modifiers.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module WebGear.Modifiers 7 | ( Existence (..) 8 | , ParseStyle (..) 9 | ) where 10 | 11 | 12 | -- | Modifier used to indicate whether a trait is required or 13 | -- optional. 14 | data Existence = Required | Optional 15 | 16 | -- | Modifier used to indicate whether a trait is parsed strictly or 17 | -- leniently. 18 | data ParseStyle = Strict | Lenient 19 | -------------------------------------------------------------------------------- /webgear-server/test/Unit.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module Unit 7 | ( unitTests 8 | ) where 9 | 10 | import Test.Tasty (TestTree, testGroup) 11 | 12 | import qualified Unit.Trait.Header as Header 13 | import qualified Unit.Trait.Path as Path 14 | 15 | 16 | unitTests :: TestTree 17 | unitTests = testGroup "Unit Tests" [ Header.tests 18 | , Path.tests 19 | ] 20 | -------------------------------------------------------------------------------- /webgear-server/test/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module Main where 7 | 8 | import Test.Tasty (TestTree, defaultMain, testGroup) 9 | 10 | import Properties (propertyTests) 11 | import Unit (unitTests) 12 | 13 | 14 | main :: IO () 15 | main = defaultMain allTests 16 | 17 | allTests :: TestTree 18 | allTests = testGroup "Tests" [unitTests, propertyTests, systemTests] 19 | 20 | systemTests :: TestTree 21 | systemTests = testGroup "System Tests" [] 22 | -------------------------------------------------------------------------------- /webgear-server/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - HTTP API server 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-server)](https://hackage.haskell.org/package/webgear-server) 4 | [![Build Status](https://img.shields.io/github/workflow/status/rkaippully/webgear/Haskell%20CI/master)](https://github.com/rkaippully/webgear/actions?query=workflow%3A%22Haskell+CI%22+branch%3Amaster) 5 | 6 | WebGear is a Haskell library for building composable, type-safe HTTP API servers. It focuses on good documentation and 7 | usability. 8 | 9 | See the documentation of WebGear module to get started. 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WebGear - HTTP API server 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-server)](https://hackage.haskell.org/package/webgear-server) 4 | [![Build Status](https://img.shields.io/github/workflow/status/rkaippully/webgear/Haskell%20CI/master)](https://github.com/rkaippully/webgear/actions?query=workflow%3A%22Haskell+CI%22+branch%3Amaster) 5 | 6 | WebGear is a Haskell library for building composable, type-safe HTTP API servers. It focuses on good documentation and 7 | usability. 8 | 9 | The library is located in the webgear-server package. Some examples are given in the webgear-examples package. 10 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | - imports: 8 | align: none 9 | list_align: after_alias 10 | pad_module_names: false 11 | long_list_align: inline 12 | empty_list_align: inherit 13 | list_padding: 4 14 | separate_lists: true 15 | space_surround: false 16 | 17 | - language_pragmas: 18 | style: vertical 19 | align: true 20 | remove_redundant: true 21 | language_prefix: LANGUAGE 22 | 23 | - trailing_whitespace: {} 24 | 25 | columns: 100 26 | newline: native 27 | cabal: true 28 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares provided by WebGear. 7 | -- 8 | module WebGear.Middlewares 9 | ( module WebGear.Middlewares.Method 10 | , module WebGear.Middlewares.Path 11 | , module WebGear.Middlewares.Header 12 | , module WebGear.Middlewares.Body 13 | , module WebGear.Middlewares.Params 14 | , module WebGear.Middlewares.Auth.Basic 15 | , module WebGear.Middlewares.Auth.JWT 16 | ) where 17 | 18 | import WebGear.Middlewares.Auth.Basic 19 | import WebGear.Middlewares.Auth.JWT 20 | import WebGear.Middlewares.Body 21 | import WebGear.Middlewares.Header 22 | import WebGear.Middlewares.Method 23 | import WebGear.Middlewares.Params 24 | import WebGear.Middlewares.Path 25 | -------------------------------------------------------------------------------- /webgear-server/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-server 2 | 3 | ## Unreleased changes 4 | 5 | ## [0.2.1] - 2021-01-11 6 | 7 | ### Changed 8 | - Upgrade to latest version of LTS and deps 9 | 10 | ## [0.2.0] - 2020-09-11 11 | 12 | ### Added 13 | - Support GHC 8.10 and 8.6 (#10) 14 | - Added more traits and middlewares (#7) 15 | - Performance benchmarks (#6) 16 | - Set up a website (#13) 17 | 18 | ### Changed 19 | - A lot of refactorings (#20, #21, #22, #23) 20 | 21 | ## [0.1.0] - 2020-08-16 22 | 23 | ### Added 24 | - Support basic traits and middlewares 25 | - Automated tests 26 | - Documentation 27 | 28 | [Unreleased]: https://github.com/rkaippully/webgear/compare/v0.2.0...HEAD 29 | [0.2.1]: https://github.com/rkaippully/webgear/compare/v0.2.0...v0.2.1 30 | [0.2.0]: https://github.com/rkaippully/webgear/compare/v0.1.0...v0.2.0 31 | [0.1.0]: https://github.com/rkaippully/webgear/releases/tag/v0.1.0 32 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Util.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Common utility functions. 7 | module WebGear.Util 8 | ( takeWhileM 9 | , splitOn 10 | , maybeToRight 11 | ) where 12 | 13 | import Data.List.NonEmpty (NonEmpty (..), toList) 14 | 15 | 16 | takeWhileM :: Monad m => (a -> Bool) -> [m a] -> m [a] 17 | takeWhileM _ [] = pure [] 18 | takeWhileM p (mx:mxs) = do 19 | x <- mx 20 | if p x 21 | then (x :) <$> takeWhileM p mxs 22 | else pure [] 23 | 24 | splitOn :: Eq a => a -> [a] -> NonEmpty [a] 25 | splitOn sep = foldr f ([] :| []) 26 | where 27 | f x acc | x == sep = [] :| toList acc 28 | f x (y :| ys) = (x:y) :| ys 29 | 30 | maybeToRight :: a -> Maybe b -> Either a b 31 | maybeToRight _ (Just x) = Right x 32 | maybeToRight y Nothing = Left y 33 | -------------------------------------------------------------------------------- /webgear-server/test/Unit/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module Unit.Trait.Path 7 | ( tests 8 | ) where 9 | 10 | import Control.Monad.State (evalState) 11 | import Network.Wai (defaultRequest) 12 | import Test.Tasty (TestTree, testGroup) 13 | import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) 14 | import WebGear.Middlewares.Path 15 | import WebGear.Trait 16 | import WebGear.Types 17 | 18 | 19 | testMissingPathVar :: TestTree 20 | testMissingPathVar = testCase "PathVar match: missing variable" $ do 21 | let req = linkzero $ defaultRequest { pathInfo = [] } 22 | case evalState (tryLink (PathVar @"tag" @Int) req) (PathInfo []) of 23 | Right _ -> assertFailure "unexpected success" 24 | Left e -> e @?= PathVarNotFound 25 | 26 | tests :: TestTree 27 | tests = testGroup "Trait.Path" [ testMissingPathVar ] 28 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | multi: 3 | - path: "./webgear-server/src" 4 | config: 5 | cradle: 6 | stack: 7 | component: "webgear-server:lib" 8 | - path: "./webgear-server/test" 9 | config: 10 | cradle: 11 | stack: 12 | component: "webgear-server:webgear-server-test" 13 | - path: "./webgear-examples/hello" 14 | config: 15 | cradle: 16 | stack: 17 | component: "webgear-examples:exe:hello" 18 | - path: "./webgear-examples/users" 19 | config: 20 | cradle: 21 | stack: 22 | component: "webgear-examples:exe:users" 23 | - path: "./webgear-examples/realworld" 24 | config: 25 | cradle: 26 | stack: 27 | component: "webgear-examples:exe:realworld" 28 | - path: "./webgear-benchmarks/src/users" 29 | config: 30 | cradle: 31 | stack: 32 | component: "webgear-benchmarks:exe:bench-users" 33 | -------------------------------------------------------------------------------- /webgear-server/.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: 2 | - -XApplicativeDo 3 | - -XBangPatterns 4 | - -XConstraintKinds 5 | - -XDataKinds 6 | - -XDefaultSignatures 7 | - -XDeriveAnyClass 8 | - -XDeriveFoldable 9 | - -XDeriveFunctor 10 | - -XDeriveGeneric 11 | - -XDeriveLift 12 | - -XDeriveTraversable 13 | - -XDerivingStrategies 14 | - -XDerivingVia 15 | - -XEmptyCase 16 | - -XExistentialQuantification 17 | - -XFlexibleContexts 18 | - -XFlexibleInstances 19 | - -XFunctionalDependencies 20 | - -XGADTs 21 | - -XGeneralizedNewtypeDeriving 22 | - -XInstanceSigs 23 | - -XKindSignatures 24 | - -XLambdaCase 25 | - -XMultiParamTypeClasses 26 | - -XMultiWayIf 27 | - -XNamedFieldPuns 28 | - -XOverloadedStrings 29 | - -XPatternSynonyms 30 | - -XPolyKinds 31 | - -XRankNTypes 32 | - -XScopedTypeVariables 33 | - -XStandaloneDeriving 34 | - -XTemplateHaskell 35 | - -XTupleSections 36 | - -XTypeApplications 37 | - -XTypeFamilies 38 | - -XTypeFamilyDependencies 39 | - -XTypeOperators -------------------------------------------------------------------------------- /webgear-server/test/Properties.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module Properties 7 | ( propertyTests 8 | ) where 9 | 10 | import Test.Tasty (TestTree, testGroup) 11 | 12 | import qualified Properties.Trait.Auth.Basic as Basic 13 | import qualified Properties.Trait.Body as Body 14 | import qualified Properties.Trait.Header as Header 15 | import qualified Properties.Trait.Method as Method 16 | import qualified Properties.Trait.Params as Params 17 | import qualified Properties.Trait.Path as Path 18 | 19 | 20 | propertyTests :: TestTree 21 | propertyTests = testGroup "Property Tests" [ Method.tests 22 | , Path.tests 23 | , Header.tests 24 | , Params.tests 25 | , Body.tests 26 | , Basic.tests 27 | ] 28 | -------------------------------------------------------------------------------- /webgear-benchmarks/README.md: -------------------------------------------------------------------------------- 1 | # WebGear Benchmarking 2 | Some benchmarks comparing webgear against other Haskell web frameworks. 3 | 4 | ## Users benchmark 5 | 6 | ### Criterion 7 | This benchmark runs a sequence of PUT, GET, and DELETE operations with criterion. This can be run with the following 8 | commands: 9 | 10 | ``` 11 | stack build 12 | stack exec bench-users -- --time-limit 15 13 | ``` 14 | 15 | Results are available [here](https://rkaippully.github.io/webgear/static/bench-criterion-users.html). 16 | 17 | ### ApacheBench 18 | This benchmark runs a sequence of 50000 PUT operations with ApacheBench. This can be run with the following commands: 19 | 20 | ``` 21 | stack build 22 | 23 | stack build; stack exec bench-users -- # library is one of webgear, servant, scotty 24 | ab -k -c 3 -n 50000 -T application/json -u user.json http://localhost:3000/v1/users/1 25 | ``` 26 | 27 | Results are available [here](results/bench-ab-users.txt) 28 | 29 | ## Test environment 30 | These benchmarks were run on a Thinkpad T450, Intel Core i5-5300U (2 core, 4 threads), 8 GB RAM running MX Linux 19.2 31 | (Debian 10). 32 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/users/Scotty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Scotty where 5 | 6 | import Network.HTTP.Types (noContent204, notFound404) 7 | import Network.Wai 8 | import Web.Scotty 9 | 10 | import Model 11 | 12 | 13 | application :: UserStore -> IO Application 14 | application store = scottyApp $ do 15 | get "/v1/users/:userId" $ getUser store 16 | put "/v1/users/:userId" $ putUser store 17 | delete "/v1/users/:userId" $ deleteUser store 18 | 19 | getUser :: UserStore -> ActionM () 20 | getUser store = do 21 | uid <- param "userId" 22 | lookupUser store (UserId uid) >>= \case 23 | Just user -> json user 24 | Nothing -> respondNotFound 25 | 26 | putUser :: UserStore -> ActionM () 27 | putUser store = do 28 | uid <- param "userId" 29 | user <- jsonData 30 | let user' = user { userId = UserId uid } 31 | addUser store user' 32 | json user' 33 | 34 | deleteUser :: UserStore -> ActionM () 35 | deleteUser store = do 36 | uid <- param "userId" 37 | found <- removeUser store (UserId uid) 38 | if found 39 | then status noContent204 >> raw "" 40 | else respondNotFound 41 | 42 | respondNotFound :: ActionM () 43 | respondNotFound = do 44 | status notFound404 45 | text "Not found" 46 | finish 47 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Method 2 | ( tests 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Network.HTTP.Types (StdMethod (..), methodGet, renderStdMethod) 7 | import Network.Wai (defaultRequest) 8 | import Test.QuickCheck (Arbitrary (arbitrary), Property, allProperties, elements, property, (.&&.), 9 | (=/=), (===)) 10 | import Test.Tasty (TestTree) 11 | import Test.Tasty.QuickCheck (testProperties) 12 | import WebGear.Middlewares.Method 13 | import WebGear.Trait 14 | import WebGear.Types 15 | 16 | 17 | newtype MethodWrapper = MethodWrapper StdMethod 18 | deriving stock (Show) 19 | 20 | instance Arbitrary MethodWrapper where 21 | arbitrary = elements $ MethodWrapper <$> [minBound..maxBound] 22 | 23 | prop_methodMatch :: Property 24 | prop_methodMatch = property $ \(MethodWrapper v) -> 25 | let 26 | req = linkzero $ defaultRequest { requestMethod = renderStdMethod v } 27 | in 28 | case runIdentity (tryLink (Method :: Method GET) req) of 29 | Right _ -> v === GET 30 | Left e -> 31 | expectedMethod e === methodGet .&&. actualMethod e =/= methodGet 32 | 33 | 34 | -- Hack for TH splicing 35 | return [] 36 | 37 | tests :: TestTree 38 | tests = testProperties "Trait.Method" $allProperties 39 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Model.Common where 4 | 5 | import Control.Monad.Logger (runStdoutLoggingT) 6 | import Data.Aeson (Options (..), defaultOptions) 7 | import Data.Char (isLower, isUpper, toLower) 8 | import Data.Pool (Pool, withResource) 9 | import Database.Esqueleto 10 | import Database.Persist.Sqlite (withSqlitePool) 11 | import Model.Entities (migrateAll) 12 | import Relude 13 | 14 | #if MIN_VERSION_esqueleto(3, 2, 0) 15 | import Database.Esqueleto.Internal.Internal (Update) 16 | #else 17 | import Database.Esqueleto.Internal.Language (Update) 18 | #endif 19 | 20 | 21 | -- All DB operations run in this monad 22 | type DBAction a = ReaderT SqlBackend IO a 23 | 24 | withDBConnectionPool :: (Pool SqlBackend -> IO a) -> IO a 25 | withDBConnectionPool f = runStdoutLoggingT $ 26 | withSqlitePool "realworld.db" 20 $ \pool -> do 27 | withResource pool $ runSqlConn (runMigration migrateAll) 28 | liftIO $ f pool 29 | 30 | -- An optional update operator 31 | (=?.) :: (PersistEntity v, PersistField typ) => EntityField v typ -> Maybe typ -> Maybe (SqlExpr (Update v)) 32 | fld =?. mv = fmap (\v -> fld =. val v) mv 33 | 34 | -- Aeson options to drop the entity name prefix from field names 35 | dropPrefixOptions :: Options 36 | dropPrefixOptions = defaultOptions 37 | { fieldLabelModifier = lowerFirst . dropWhile isLower 38 | } 39 | where 40 | lowerFirst :: String -> String 41 | lowerFirst (c:cs) | isUpper c = toLower c:cs 42 | lowerFirst s = s 43 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Params.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Params 2 | ( tests 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.String (fromString) 7 | import Data.Text.Encoding (encodeUtf8) 8 | import Network.Wai (defaultRequest) 9 | import Test.QuickCheck (Property, allProperties, counterexample, property, (===)) 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty (TestTree) 12 | import Test.Tasty.QuickCheck (testProperties) 13 | import WebGear.Middlewares.Params 14 | import WebGear.Trait 15 | import WebGear.Types 16 | 17 | 18 | prop_paramParseError :: Property 19 | prop_paramParseError = property $ \hval -> 20 | let 21 | hval' = "test-" <> hval 22 | req = linkzero $ defaultRequest { queryString = [("foo", Just $ encodeUtf8 hval')] } 23 | in 24 | case runIdentity (tryLink (QueryParam' :: QueryParam "foo" Int) req) of 25 | Right v -> 26 | counterexample ("Unexpected result: " <> show v) (property False) 27 | Left e -> 28 | e === Right (ParamParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") 29 | 30 | prop_paramParseSuccess :: Property 31 | prop_paramParseSuccess = property $ \(n :: Int) -> 32 | let 33 | req = linkzero $ defaultRequest { queryString = [("foo", Just $ fromString $ show n)] } 34 | in 35 | case runIdentity (tryLink (QueryParam' :: QueryParam "foo" Int) req) of 36 | Right n' -> n === n' 37 | Left e -> 38 | counterexample ("Unexpected result: " <> show e) (property False) 39 | 40 | 41 | -- Hack for TH splicing 42 | return [] 43 | 44 | tests :: TestTree 45 | tests = testProperties "Trait.Params" $allProperties 46 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Entities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Model.Entities where 13 | 14 | import Data.Time.Clock (UTCTime) 15 | import Database.Esqueleto 16 | import Database.Persist.TH 17 | import Relude 18 | 19 | 20 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 21 | User 22 | username Text 23 | email Text 24 | password Text 25 | bio Text Maybe 26 | image Text Maybe 27 | UniqueUsername username 28 | UniqueEmail email 29 | 30 | Article 31 | slug Text 32 | title Text 33 | description Text 34 | body Text 35 | createdAt UTCTime 36 | updatedAt UTCTime 37 | author UserId 38 | UniqueSlug slug 39 | 40 | ArticleTag 41 | tagid TagId 42 | articleid ArticleId 43 | ArticlesWithTag tagid articleid 44 | TagsOfArticle articleid tagid 45 | 46 | Tag 47 | name Text 48 | UniqueTagName name 49 | 50 | Comment 51 | createdAt UTCTime 52 | updatedAt UTCTime 53 | body Text 54 | article ArticleId 55 | author UserId 56 | 57 | Favorite 58 | userid UserId 59 | articleid ArticleId 60 | UniqueFavorite articleid userid 61 | 62 | Follow 63 | follower UserId 64 | followee UserId 65 | UniqueFollow follower followee 66 | |] 67 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Path 2 | ( tests 3 | ) where 4 | 5 | import Control.Monad.State.Strict (evalState) 6 | import Data.String (fromString) 7 | import Network.Wai (defaultRequest) 8 | import Test.QuickCheck (Property, allProperties, property, (=/=), (===)) 9 | import Test.QuickCheck.Instances () 10 | import Test.Tasty (TestTree) 11 | import Test.Tasty.QuickCheck (testProperties) 12 | import WebGear.Middlewares.Path 13 | import WebGear.Trait 14 | import WebGear.Types 15 | 16 | 17 | prop_pathMatch :: Property 18 | prop_pathMatch = property $ \h -> 19 | let 20 | rest = ["foo", "bar"] 21 | req = linkzero $ defaultRequest { pathInfo = h:rest } 22 | in 23 | case evalState (tryLink (Path @"a") req) (PathInfo $ h:rest) of 24 | Right _ -> h === "a" 25 | Left _ -> h =/= "a" 26 | 27 | prop_pathVarMatch :: Property 28 | prop_pathVarMatch = property $ \(n :: Int) -> 29 | let 30 | rest = ["foo", "bar"] 31 | req = defaultRequest { pathInfo = fromString (show n):rest } 32 | in 33 | case evalState (tryLink (PathVar @"tag" @Int) (linkzero req)) (PathInfo $ pathInfo req) of 34 | Right n' -> n' === n 35 | Left _ -> property False 36 | 37 | prop_pathVarParseError :: Property 38 | prop_pathVarParseError = property $ \(p, ps) -> 39 | let 40 | p' = "test-" <> p 41 | req = defaultRequest { pathInfo = p':ps } 42 | in 43 | case evalState (tryLink (PathVar @"tag" @Int) (linkzero req)) (PathInfo $ pathInfo req) of 44 | Right _ -> property False 45 | Left e -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)") 46 | 47 | 48 | -- Hack for TH splicing 49 | return [] 50 | 51 | tests :: TestTree 52 | tests = testProperties "Trait.Path" $allProperties 53 | -------------------------------------------------------------------------------- /webgear-server/test/Unit/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | module Unit.Trait.Header 7 | ( tests 8 | ) where 9 | 10 | import Network.Wai (defaultRequest) 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) 13 | import WebGear.Middlewares.Header 14 | import WebGear.Trait 15 | import WebGear.Types 16 | 17 | 18 | testMissingHeaderFails :: TestTree 19 | testMissingHeaderFails = testCase "Missing header fails Header trait" $ do 20 | let req = linkzero $ defaultRequest { requestHeaders = [] } 21 | tryLink (Header' :: Header "foo" Int) req >>= \case 22 | Right _ -> assertFailure "unexpected success" 23 | Left e -> e @?= Left HeaderNotFound 24 | 25 | testHeaderMatchPositive :: TestTree 26 | testHeaderMatchPositive = testCase "Header match: positive" $ do 27 | let req = linkzero $ defaultRequest { requestHeaders = [("foo", "bar")] } 28 | tryLink (HeaderMatch' :: HeaderMatch "foo" "bar") req >>= \case 29 | Right _ -> pure () 30 | Left e -> assertFailure $ "Unexpected result: " <> show e 31 | 32 | testHeaderMatchMissingHeader :: TestTree 33 | testHeaderMatchMissingHeader = testCase "Header match: missing header" $ do 34 | let req = linkzero $ defaultRequest { requestHeaders = [] } 35 | tryLink (HeaderMatch' :: HeaderMatch "foo" "bar") req >>= \case 36 | Right _ -> assertFailure "unexpected success" 37 | Left e -> e @?= Nothing 38 | 39 | tests :: TestTree 40 | tests = testGroup "Trait.Header" [ testMissingHeaderFails 41 | , testHeaderMatchPositive 42 | , testHeaderMatchMissingHeader 43 | ] 44 | -------------------------------------------------------------------------------- /webgear-examples/realworld/realworld.jwk: -------------------------------------------------------------------------------- 1 | { 2 | "p": "66FH3ZnC2Mbr_uzZewvyq2CKoVmoTC1BSAlyKZwCx3_LynkiQkUkEae_KhXcu_wryU7GHsdCTfDisW1wL4hl4IARmHaNfhOKuKcCj7M6byeZqJNOOaNxOuM0XKB38wEh2j8IA_1ZIQA24zNyM4BBNxWWcRmpMMtK0qRS82F3vmM", 3 | "kty": "RSA", 4 | "q": "pguCvmVp91hxj9rgFwdjMktY9sXfNXfgwNrOj3gaOgFWPWVQhSerj0hGAgCb8i4IxoLIDjuDXHKOJDHzHMbkR6ZPEGryKqqH1pan7qqyir8XsVmGkUdtls53_vg7pcQfoWVBiFWqXRZSo14WOOGqvoHB71_6kVBqIRNknAvjIHU", 5 | "d": "Hi0ZKvsvU1e3K1kRlfKye9j2A9FgXoVmucl5UCkn5Or-xEkT8nUmRMgHpETUQpolo8Zd4HK3CU5ovplfi4rNs0DFd0526ZAL0QK6vYD5AiJ31Gog9RtVXsx6uxZXE6CxkvxgLVH0s4uQ3Qg77sfnZA3uU4qNbuGwgh9PrxUncyT2THtCD35jxFjcdFhPYH3im8-G2t0EmSXr4jKoudl3inWFOgSbtOihUXkPNFPy5e5gNQzM4sM8RjAq9bYtG3OPpQ0iEYfAi614UnzpJBoNi5dhGm5kUQKceg_f9wfIVWQDPBTGm5KEdGIxXo8A_vruKlairI-Vzqyzo4tmbrO44Q", 6 | "e": "AQAB", 7 | "use": "sig", 8 | "kid": "aVhNluSUmDaHkYvk7xeBcI5Sn7udUtEzCTBtoZj3kuU", 9 | "qi": "IufHlRbkA1baNqNfMXgDlrBz_i0V7qCkOfILyoE2X_KKkwWO3FzGgmkRCXjh5JlY4L6SL7w6C1RQQY5TZd2c0Zt0oGZWwOMDJM3_FIMb4Gd9WgzUtf9e1lpwSNzopxbPs_26h19SRJLsZ9LF9gObqhsg11hAA7DOIpXn59nKFb0", 10 | "dp": "o1WQEH-GfmgdrP-XneDhXYS1dDVHIU75gqrxlQBNOOdQZ9DiO5fb8dUbAVxYP4MFAy10zl8HiimhqqYW7wwYuq9sAwii-jMnpOo4L05pAiYsMJuzzOaMFerrIA4oN62gPr4Um1diEiso4QOHdUXBbyKqv0mva2BwRGWeDpGQxMs", 11 | "alg": "RS256", 12 | "dq": "TuD2-jW5Eixsvjbu72GuCO1sVMaJE6BgH52SNOuMIfQSoNXpW2gOAuIFh9v8OR8PQiZMnR4-eANfbOhholEFjtf9hUIYypX6M8GcAzAJ4wmGWtS5rXguIk7xCCmqREQX9pbge8CeTtxU45DFo73oW9nOZEXHBZMa552L1Ol8uyU", 13 | "n": "mNUs3u3D_KhKIWZCnJzaYeDbnRHjWe6JM_7LkPGtgPebApu9wVjh41HVWjj8voY3guN3EuzCl5IzsdtnNZ7Y8sEaMe62pJQ_Aw62ziO9RaDCzpRnfiVmhXUR9HexsiCMTI_FUNanFSJaOaGw2JZ6Qw2UP3u02cK84-dYhQqndFeJob5QjpNbS4jwdLpbQE8K5AmhqqUr07a_sdC59YgaMWLqLzOp8BoPImWSRx9SfDa9oEZH6Gw5feFi6jFDAQn1_aOCym1rj2xMStOi3i_MWisS5e_AsoFkBuh2AXh4gcLNEq4aI98rm7GaNW2CQ0uTkZWRXUZtKZriJ5galk9jPw" 14 | } -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Handlers/Static.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Handler serving static resources 7 | module WebGear.Handlers.Static 8 | ( serveDir 9 | , serveFile 10 | ) where 11 | 12 | import Control.Arrow (Kleisli (..)) 13 | import Control.Exception.Safe (catchIO) 14 | import Control.Monad.IO.Class (MonadIO (..)) 15 | import Control.Monad.State.Strict (MonadState (..)) 16 | import Prelude hiding (readFile) 17 | import System.FilePath (joinPath, takeFileName, ()) 18 | 19 | import WebGear.Types (Handler', MonadRouter (..), PathInfo (..), Response, notFound404, ok200, 20 | setResponseHeader) 21 | 22 | import qualified Data.ByteString.Lazy as LBS 23 | import qualified Data.Text as Text 24 | import qualified Network.Mime as Mime 25 | 26 | 27 | serveDir :: (MonadRouter m, MonadIO m) 28 | => FilePath -- ^ directory to serve 29 | -> Maybe FilePath -- ^ index filename for the root directory 30 | -> Handler' m req LBS.ByteString 31 | serveDir root index = Kleisli $ \_req -> do 32 | PathInfo restPath <- get 33 | case restPath of 34 | [] -> serveIndex 35 | ps -> serveFile $ root joinPath (Text.unpack <$> ps) 36 | where 37 | serveIndex = maybe 38 | (pure notFound404) 39 | (\f -> serveFile $ root f) 40 | index 41 | 42 | serveFile :: (MonadRouter m, MonadIO m) => FilePath -> m (Response LBS.ByteString) 43 | serveFile f = do 44 | contents <- liftIO $ (Just <$> LBS.readFile f) `catchIO` const (pure Nothing) 45 | let mimeType = Mime.defaultMimeLookup $ Text.pack $ takeFileName f 46 | mkResponse = pure . setResponseHeader "Content-Type" mimeType . ok200 47 | maybe (errorResponse notFound404) mkResponse contents 48 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Body.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-deprecations #-} 2 | 3 | module Properties.Trait.Body 4 | ( tests 5 | ) where 6 | 7 | import Control.Monad.IO.Class (MonadIO, liftIO) 8 | import Data.IORef (newIORef, readIORef, writeIORef) 9 | import Data.String (fromString) 10 | import Network.Wai (defaultRequest, requestBody) 11 | import Test.QuickCheck (Property, allProperties, counterexample, property) 12 | import Test.QuickCheck.Instances () 13 | import Test.QuickCheck.Monadic (assert, monadicIO, monitor) 14 | import Test.Tasty (TestTree) 15 | import Test.Tasty.QuickCheck (testProperties) 16 | import WebGear.Middlewares.Body 17 | import WebGear.Trait 18 | import WebGear.Types 19 | 20 | 21 | bodyToRequest :: (MonadIO m, Show a) => a -> m (Linked '[] Request) 22 | bodyToRequest x = do 23 | body <- liftIO $ newIORef $ Just $ fromString $ show x 24 | let f = readIORef body >>= maybe (pure "") (\s -> writeIORef body Nothing >> pure s) 25 | return $ linkzero $ defaultRequest { requestBody = f } 26 | 27 | prop_emptyRequestBodyFails :: Property 28 | prop_emptyRequestBodyFails = monadicIO $ do 29 | req <- bodyToRequest ("" :: String) 30 | tryLink (JSONBody @Int) req >>= \case 31 | Right _ -> monitor (counterexample "Unexpected success") >> assert False 32 | Left _ -> assert True 33 | 34 | prop_validBodyParses :: Property 35 | prop_validBodyParses = property $ \n -> monadicIO $ do 36 | req <- bodyToRequest (n :: Integer) 37 | tryLink JSONBody req >>= \case 38 | Right n' -> assert (n == n') 39 | Left _ -> assert False 40 | 41 | prop_invalidBodyTypeFails :: Property 42 | prop_invalidBodyTypeFails = property $ \n -> monadicIO $ do 43 | req <- bodyToRequest (n :: Integer) 44 | tryLink (JSONBody @String) req >>= \case 45 | Right _ -> assert False 46 | Left _ -> assert True 47 | 48 | 49 | -- Hack for TH splicing 50 | return [] 51 | 52 | tests :: TestTree 53 | tests = testProperties "Trait.Body" $allProperties 54 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/Profile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module API.Profile 5 | ( getByName 6 | , follow 7 | , unfollow 8 | ) where 9 | 10 | import API.Common 11 | import qualified Model.Profile as Model 12 | import Relude 13 | import WebGear 14 | 15 | 16 | type ProfileResponse = Wrapped "profile" Model.Profile 17 | 18 | getByName :: HasTrait (PathVar "username" Text) req => Handler' App req LByteString 19 | getByName = optionalTokenAuth 20 | $ jsonResponseBody @ProfileResponse 21 | $ handler 22 | where 23 | handler = Kleisli $ \request -> do 24 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 25 | username = pick @(PathVar "username" Text) $ from request 26 | maybeProfile <- runDBAction $ Model.getByName maybeCurrentUserId username 27 | pure $ maybe notFound404 (ok200 . Wrapped) maybeProfile 28 | 29 | follow :: HasTrait (PathVar "username" Text) req => Handler' App req LByteString 30 | follow = requiredTokenAuth 31 | $ jsonResponseBody @ProfileResponse 32 | $ handler 33 | where 34 | handler = Kleisli $ \request -> do 35 | let currentUserId = pick @RequiredAuth $ from request 36 | username = pick @(PathVar "username" Text) $ from request 37 | maybeProfile <- runDBAction $ Model.follow currentUserId username 38 | pure $ maybe notFound404 (ok200 . Wrapped) maybeProfile 39 | 40 | 41 | unfollow :: HasTrait (PathVar "username" Text) req => Handler' App req LByteString 42 | unfollow = requiredTokenAuth 43 | $ jsonResponseBody @ProfileResponse 44 | $ handler 45 | where 46 | handler = Kleisli $ \request -> do 47 | let currentUserId = pick @RequiredAuth $ from request 48 | username = pick @(PathVar "username" Text) $ from request 49 | maybeProfile <- runDBAction $ Model.unfollow currentUserId username 50 | pure $ maybe notFound404 (ok200 . Wrapped) maybeProfile 51 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/users/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | 5 | module Model where 6 | 7 | import Control.Monad.IO.Class (MonadIO (..)) 8 | import Data.Aeson (FromJSON, ToJSON) 9 | import Data.Hashable (Hashable) 10 | import Data.IORef (IORef, modifyIORef, newIORef, readIORef) 11 | import Data.Maybe (isJust) 12 | import Data.Text (Text) 13 | import Data.Time.Calendar (Day) 14 | import GHC.Generics (Generic) 15 | 16 | import qualified Data.HashMap.Strict as HM 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | -- Model for users 21 | -------------------------------------------------------------------------------- 22 | data User = User 23 | { userId :: UserId 24 | , userName :: Text 25 | , dateOfBirth :: Day 26 | , gender :: Gender 27 | , emailAddress :: Text 28 | } 29 | deriving (Generic, FromJSON, ToJSON) 30 | 31 | newtype UserId = UserId Int 32 | deriving (Eq, FromJSON, ToJSON, Hashable) via Int 33 | 34 | data Gender = Male | Female | OtherGender 35 | deriving (Generic, FromJSON, ToJSON) 36 | 37 | 38 | -------------------------------------------------------------------------------- 39 | -- An in-memory store and associated operations for users 40 | -------------------------------------------------------------------------------- 41 | newtype UserStore = UserStore (IORef (HM.HashMap UserId User)) 42 | 43 | newStore :: MonadIO m => m UserStore 44 | newStore = UserStore <$> liftIO (newIORef HM.empty) 45 | 46 | addUser :: MonadIO m => UserStore -> User -> m () 47 | addUser (UserStore ref) user = liftIO $ modifyIORef ref (HM.insert (userId user) user) 48 | 49 | lookupUser :: MonadIO m => UserStore -> UserId -> m (Maybe User) 50 | lookupUser (UserStore ref) uid = liftIO (HM.lookup uid <$> readIORef ref) 51 | 52 | removeUser :: MonadIO m => UserStore -> UserId -> m Bool 53 | removeUser store@(UserStore ref) uid = liftIO $ do 54 | u <- lookupUser store uid 55 | modifyIORef ref (HM.delete uid) 56 | pure $ isJust u 57 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Auth.Basic 2 | ( tests 3 | ) where 4 | 5 | import Data.ByteString.Base64 (encode) 6 | import Data.ByteString.Char8 (elem) 7 | import Data.Either (fromRight) 8 | import Data.Functor.Identity (Identity, runIdentity) 9 | import Network.Wai (defaultRequest) 10 | import Prelude hiding (elem) 11 | import Test.QuickCheck (Discard (..), Property, allProperties, counterexample, property, (.&&.), 12 | (===)) 13 | import Test.QuickCheck.Instances () 14 | import Test.Tasty (TestTree) 15 | import Test.Tasty.QuickCheck (testProperties) 16 | import WebGear.Middlewares.Auth.Basic 17 | import WebGear.Middlewares.Auth.Util (AuthorizationHeader) 18 | import WebGear.Middlewares.Header (Header' (Header')) 19 | import WebGear.Trait 20 | import WebGear.Types 21 | 22 | 23 | prop_basicAuth :: Property 24 | prop_basicAuth = property f 25 | where 26 | f (username, password) 27 | | ':' `elem` username = property Discard 28 | | otherwise = 29 | let 30 | hval = "Basic " <> encode (username <> ":" <> password) 31 | 32 | req :: Linked '[AuthorizationHeader "Basic"] Request 33 | req = fromRight undefined 34 | $ runIdentity 35 | $ probe Header' 36 | $ linkzero 37 | $ defaultRequest { requestHeaders = [("Authorization", hval)] } 38 | 39 | toBasicAttribute :: Credentials -> Identity (Either () Credentials) 40 | toBasicAttribute = pure . Right 41 | 42 | authCfg :: BasicAuth Identity () Credentials 43 | authCfg = BasicAuth'{..} 44 | in 45 | case runIdentity (tryLink authCfg req) of 46 | Right creds -> 47 | credentialsUsername creds === Username username 48 | .&&. credentialsPassword creds === Password password 49 | Left e -> 50 | counterexample ("Unexpected failure: " <> show e) (property False) 51 | 52 | 53 | -- Hack for TH splicing 54 | return [] 55 | 56 | tests :: TestTree 57 | tests = testProperties "Trait.Auth.Basic" $allProperties 58 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Header 2 | ( tests 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.String (fromString) 7 | import Data.Text.Encoding (encodeUtf8) 8 | import Network.Wai (defaultRequest) 9 | import Test.QuickCheck (Property, allProperties, counterexample, property, (.&&.), (=/=), (===)) 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty (TestTree) 12 | import Test.Tasty.QuickCheck (testProperties) 13 | import WebGear.Middlewares.Header 14 | import WebGear.Trait 15 | import WebGear.Types 16 | 17 | 18 | prop_headerParseError :: Property 19 | prop_headerParseError = property $ \hval -> 20 | let 21 | hval' = "test-" <> hval 22 | req = linkzero $ defaultRequest { requestHeaders = [("foo", encodeUtf8 hval')] } 23 | in 24 | case runIdentity (tryLink (Header' :: Header "foo" Int) req) of 25 | Right v -> 26 | counterexample ("Unexpected result: " <> show v) (property False) 27 | Left e -> 28 | e === Right (HeaderParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") 29 | 30 | prop_headerParseSuccess :: Property 31 | prop_headerParseSuccess = property $ \(n :: Int) -> 32 | let 33 | req = linkzero $ defaultRequest { requestHeaders = [("foo", fromString $ show n)] } 34 | in 35 | case runIdentity (tryLink (Header' :: Header "foo" Int) req) of 36 | Right n' -> n === n' 37 | Left e -> 38 | counterexample ("Unexpected result: " <> show e) (property False) 39 | 40 | prop_headerMatch :: Property 41 | prop_headerMatch = property $ \v -> 42 | let 43 | req = linkzero $ defaultRequest { requestHeaders = [("foo", v)] } 44 | in 45 | case runIdentity (tryLink (HeaderMatch' :: HeaderMatch "foo" "bar") req) of 46 | Right _ -> v === "bar" 47 | Left Nothing -> 48 | counterexample "Unexpected result: Nothing" (property False) 49 | Left (Just e) -> 50 | expectedHeader e === "bar" .&&. actualHeader e =/= "bar" 51 | 52 | 53 | -- Hack for TH splicing 54 | return [] 55 | 56 | tests :: TestTree 57 | tests = testProperties "Trait.Header" $allProperties 58 | -------------------------------------------------------------------------------- /webgear-examples/realworld/ui/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Conduit 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /webgear-benchmarks/webgear-benchmarks.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-benchmarks 3 | version: 0.2.1 4 | description: Benchmarks for webgear 5 | homepage: https://github.com/rkaippully/webgear/webgear-benchmarks#readme 6 | bug-reports: https://github.com/rkaippully/webgear/issues 7 | author: Raghu Kaippully 8 | maintainer: rkaippully@gmail.com 9 | copyright: 2020 Raghu Kaippully 10 | license: MPL-2.0 11 | license-file: LICENSE 12 | build-type: Simple 13 | extra-source-files: README.md 14 | 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/rkaippully/webgear 19 | 20 | executable bench-users 21 | default-language: Haskell2010 22 | build-depends: aeson >=1.4 && <1.6 23 | , base >=4.12.0.0 && <5 24 | , bytestring ==0.10.* 25 | , criterion ==1.5.* 26 | , hashable >=1.2.7.0 && <1.4 27 | , http-types ==0.12.* 28 | , mtl ==2.2.* 29 | , text ==1.2.* 30 | , time >=1.8.0.2 && <1.10 31 | , unordered-containers ==0.2.* 32 | , servant >=0.16 && <0.19 33 | , servant-server >=0.16 && <0.19 34 | , scotty >=0.11.5 && <0.13 35 | , wai ==3.2.* 36 | , warp ==3.3.* 37 | , webgear-server 38 | ghc-options: -threaded 39 | -rtsopts 40 | -with-rtsopts=-N 41 | -Wall 42 | -Wno-unticked-promoted-constructors 43 | -Wincomplete-record-updates 44 | -Wincomplete-uni-patterns 45 | -Wredundant-constraints 46 | main-is: Main.hs 47 | other-modules: Model 48 | , WebGear 49 | , Servant 50 | , Scotty 51 | hs-source-dirs: src/users -------------------------------------------------------------------------------- /webgear-benchmarks/src/users/Servant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Servant where 7 | 8 | import Control.Monad.Except (ExceptT, MonadError, mapExceptT, throwError) 9 | import Control.Monad.IO.Class (MonadIO) 10 | import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) 11 | import Data.Proxy (Proxy (..)) 12 | import Network.Wai 13 | import Servant.API 14 | import Servant.Server 15 | 16 | import Model 17 | 18 | type UserAPI = "v1" :> "users" :> Capture "userId" Int :> Get '[JSON] User 19 | :<|> "v1" :> "users" :> Capture "userId" Int :> ReqBody '[JSON] User :> Put '[JSON] User 20 | :<|> "v1" :> "users" :> Capture "userId" Int :> Verb DELETE 204 '[JSON] NoContent 21 | 22 | application :: UserStore -> Application 23 | application store = serve userAPI $ hoistServer userAPI toHandler server 24 | where 25 | toHandler :: UserHandler a -> Handler a 26 | toHandler = Handler . mapExceptT f 27 | 28 | f :: ReaderT UserStore IO (Either ServerError a) -> IO (Either ServerError a) 29 | f x = runReaderT x store 30 | 31 | userAPI :: Proxy UserAPI 32 | userAPI = Proxy 33 | 34 | type UserHandler = ExceptT ServerError (ReaderT UserStore IO) 35 | 36 | server :: ServerT UserAPI UserHandler 37 | server = getUser :<|> putUser :<|> deleteUser 38 | 39 | getUser :: ( MonadReader UserStore m 40 | , MonadError ServerError m 41 | , MonadIO m 42 | ) 43 | => Int -> m User 44 | getUser uid = do 45 | store <- ask 46 | lookupUser store (UserId uid) >>= \case 47 | Just user -> return user 48 | Nothing -> throwError err404 49 | 50 | putUser :: ( MonadReader UserStore m 51 | , MonadIO m 52 | ) 53 | => Int -> User -> m User 54 | putUser uid user = do 55 | let user' = user { userId = UserId uid } 56 | store <- ask 57 | addUser store user' 58 | return user' 59 | 60 | deleteUser :: ( MonadReader UserStore m 61 | , MonadError ServerError m 62 | , MonadIO m 63 | ) 64 | => Int -> m NoContent 65 | deleteUser uid = do 66 | store <- ask 67 | found <- removeUser store (UserId uid) 68 | if found 69 | then return NoContent 70 | else throwError err404 71 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/Comment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module API.Comment 5 | ( create 6 | , list 7 | , API.Comment.delete 8 | ) where 9 | 10 | import API.Common 11 | import qualified Database.Persist.Sql as DB 12 | import qualified Model.Comment as Model 13 | import Relude 14 | import WebGear 15 | 16 | 17 | type CreateCommentRequest = Wrapped "comment" Model.CreateCommentPayload 18 | type CommentResponse = Wrapped "comment" Model.CommentRecord 19 | 20 | create :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 21 | create = requiredTokenAuth 22 | $ jsonRequestBody @CreateCommentRequest 23 | $ jsonResponseBody @CommentResponse 24 | $ handler 25 | where 26 | handler = Kleisli $ \request -> do 27 | let currentUserId = pick @RequiredAuth $ from request 28 | slug = pick @(PathVar "slug" Text) $ from request 29 | payload = pick @(JSONBody CreateCommentRequest) $ from request 30 | maybeComment <- runDBAction $ Model.create currentUserId slug (unwrap payload) 31 | pure $ maybe notFound404 (ok200 . Wrapped) maybeComment 32 | 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | type CommentListResponse = Wrapped "comments" [Model.CommentRecord] 37 | 38 | list :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 39 | list = optionalTokenAuth 40 | $ jsonResponseBody @CommentListResponse 41 | $ handler 42 | where 43 | handler = Kleisli $ \request -> do 44 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 45 | slug = pick @(PathVar "slug" Text) $ from request 46 | comments <- runDBAction $ Model.list maybeCurrentUserId slug 47 | pure $ ok200 $ Wrapped comments 48 | 49 | 50 | -------------------------------------------------------------------------------- 51 | 52 | delete :: HaveTraits [PathVar "slug" Text, PathVar "commentId" Int64] req 53 | => Handler' App req LByteString 54 | delete = requiredTokenAuth handler 55 | where 56 | handler = Kleisli $ \request -> do 57 | let currentUserId = pick @RequiredAuth $ from request 58 | slug = pick @(PathVar "slug" Text) $ from request 59 | commentId = pick @(PathVar "commentId" Int64) $ from request 60 | runDBAction $ Model.delete currentUserId slug (DB.toSqlKey commentId) 61 | pure noContent204 62 | 63 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Auth/Util.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Util types and functions related to authorization. 7 | -- 8 | module WebGear.Middlewares.Auth.Util 9 | ( AuthorizationHeader 10 | , authorizationHeader 11 | , Realm (..) 12 | , AuthToken (..) 13 | , respondUnauthorized 14 | ) where 15 | 16 | import Data.ByteString (ByteString, drop) 17 | import Data.ByteString.Char8 (break) 18 | import Data.CaseInsensitive (CI, mk, original) 19 | import Data.Proxy (Proxy (..)) 20 | import Data.String (IsString (..)) 21 | import Data.Text.Encoding (encodeUtf8) 22 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 23 | import Prelude hiding (break, drop) 24 | import Web.HttpApiData (FromHttpApiData (..)) 25 | import WebGear.Middlewares.Header (Header', optionalLenientHeader) 26 | import WebGear.Modifiers (Existence (..), ParseStyle (..)) 27 | import WebGear.Types (MonadRouter (errorResponse), RequestMiddleware', Response, setResponseHeader, 28 | unauthorized401) 29 | 30 | 31 | -- | Header trait for authorization 32 | type AuthorizationHeader scheme = Header' Optional Lenient "Authorization" (AuthToken scheme) 33 | 34 | authorizationHeader :: forall scheme m req a. (KnownSymbol scheme, MonadRouter m) 35 | => RequestMiddleware' m req (AuthorizationHeader scheme:req) a 36 | authorizationHeader = optionalLenientHeader @"Authorization" @(AuthToken scheme) 37 | 38 | -- | The protection space for authentication 39 | newtype Realm = Realm ByteString 40 | deriving newtype (Eq, Ord, Show, Read, IsString) 41 | 42 | data AuthToken (scheme :: Symbol) = AuthToken 43 | { authScheme :: CI ByteString 44 | , authToken :: ByteString 45 | } 46 | 47 | instance KnownSymbol scheme => FromHttpApiData (AuthToken scheme) where 48 | parseUrlPiece = parseHeader . encodeUtf8 49 | 50 | parseHeader hdr = 51 | case break (== ' ') hdr of 52 | (scm, tok) -> 53 | let 54 | actualScheme = mk scm 55 | expectedScheme = fromString $ symbolVal $ Proxy @scheme 56 | in 57 | if actualScheme == expectedScheme 58 | then Right (AuthToken actualScheme (drop 1 tok)) 59 | else Left "scheme mismatch" 60 | 61 | respondUnauthorized :: MonadRouter m => CI ByteString -> Realm -> m (Response a) 62 | respondUnauthorized scheme (Realm realm) = errorResponse 63 | $ setResponseHeader "WWW-Authenticate" (original scheme <> " realm=\"" <> realm <> "\"") 64 | $ unauthorized401 "Unauthorized" 65 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Body.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares related to HTTP body. 7 | module WebGear.Middlewares.Body 8 | ( JSONBody (..) 9 | , jsonRequestBody 10 | , jsonResponseBody 11 | ) where 12 | 13 | import Control.Arrow (Kleisli (..)) 14 | import Control.Monad ((>=>)) 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Data.Aeson (FromJSON, ToJSON, eitherDecode', encode) 17 | import Data.ByteString.Lazy (ByteString, fromChunks, fromStrict) 18 | import Data.Kind (Type) 19 | import Data.Text (Text, pack) 20 | import Data.Text.Encoding (encodeUtf8) 21 | import Network.HTTP.Types (hContentType) 22 | import WebGear.Trait (Linked, Trait (..), probe, unlink) 23 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), 24 | ResponseMiddleware', badRequest400, getRequestBodyChunk, setResponseHeader) 25 | import WebGear.Util (takeWhileM) 26 | 27 | 28 | -- | A 'Trait' for converting a JSON body into a value. 29 | data JSONBody (t :: Type) = JSONBody 30 | 31 | instance (FromJSON t, MonadIO m) => Trait (JSONBody t) ts Request m where 32 | type Attribute (JSONBody t) Request = t 33 | type Absence (JSONBody t) Request = Text 34 | 35 | tryLink :: JSONBody t 36 | -> Linked ts Request 37 | -> m (Either Text t) 38 | tryLink _ r = do 39 | chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink r 40 | pure $ case eitherDecode' (fromChunks chunks) of 41 | Left e -> Left $ pack e 42 | Right t -> Right t 43 | 44 | -- | A middleware to parse the request body as JSON and convert it to 45 | -- a value via a 'FromJSON' instance. 46 | -- 47 | -- Usage for a type @t@ which has a 'FromJSON' instance: 48 | -- 49 | -- > jsonRequestBody @t handler 50 | -- 51 | -- Returns a 400 Bad Request response on failure to parse body. 52 | jsonRequestBody :: forall t m req a. (FromJSON t, MonadRouter m, MonadIO m) 53 | => RequestMiddleware' m req (JSONBody t:req) a 54 | jsonRequestBody handler = Kleisli $ 55 | probe JSONBody >=> either (errorResponse . mkError) (runKleisli handler) 56 | where 57 | mkError :: Text -> Response ByteString 58 | mkError e = badRequest400 $ fromStrict $ encodeUtf8 $ "Error parsing request body: " <> e 59 | 60 | -- | A middleware that converts the response that has a 'ToJSON' 61 | -- instance to a 'ByteString' response. 62 | -- 63 | -- This will also set the "Content-Type" header of the response to 64 | -- "application/json". 65 | -- 66 | -- Usage for a type @t@ which has a 'ToJSON' instance: 67 | -- 68 | -- > jsonResponseBody @t handler 69 | -- 70 | jsonResponseBody :: (ToJSON t, Monad m) => ResponseMiddleware' m req t ByteString 71 | jsonResponseBody handler = Kleisli $ \req -> do 72 | x <- runKleisli handler req 73 | pure $ setResponseHeader hContentType "application/json" $ encode <$> x 74 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Method.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares related to HTTP methods. 7 | module WebGear.Middlewares.Method 8 | ( Method (..) 9 | , IsStdMethod (..) 10 | , MethodMismatch (..) 11 | , method 12 | ) where 13 | 14 | import Control.Arrow (Kleisli (..)) 15 | import Control.Monad ((>=>)) 16 | import Data.Proxy (Proxy (..)) 17 | import qualified Network.HTTP.Types as HTTP 18 | import WebGear.Trait (Linked, Trait (..), probe, unlink) 19 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', requestMethod) 20 | 21 | 22 | -- | A 'Trait' for capturing the HTTP method of a request 23 | data Method (t :: HTTP.StdMethod) = Method 24 | 25 | -- | Failure to match method against an expected value 26 | data MethodMismatch = MethodMismatch 27 | { expectedMethod :: HTTP.Method 28 | , actualMethod :: HTTP.Method 29 | } 30 | 31 | instance (IsStdMethod t, Monad m) => Trait (Method t) ts Request m where 32 | type Attribute (Method t) Request = HTTP.StdMethod 33 | type Absence (Method t) Request = MethodMismatch 34 | 35 | tryLink :: Method t 36 | -> Linked ts Request 37 | -> m (Either MethodMismatch HTTP.StdMethod) 38 | tryLink _ r = 39 | let 40 | m = toStdMethod $ Proxy @t 41 | expected = HTTP.renderStdMethod m 42 | actual = requestMethod $ unlink r 43 | in 44 | pure $ 45 | if expected == actual 46 | then Right m 47 | else Left $ MethodMismatch expected actual 48 | 49 | 50 | -- | A typeclass to map a 'HTTP.StdMethod' from type level to term 51 | -- level. 52 | class IsStdMethod t where 53 | -- | Convert @t@ to term level. 54 | toStdMethod :: Proxy t -> HTTP.StdMethod 55 | 56 | instance IsStdMethod HTTP.GET where 57 | toStdMethod = const HTTP.GET 58 | instance IsStdMethod HTTP.POST where 59 | toStdMethod = const HTTP.POST 60 | instance IsStdMethod HTTP.HEAD where 61 | toStdMethod = const HTTP.HEAD 62 | instance IsStdMethod HTTP.PUT where 63 | toStdMethod = const HTTP.PUT 64 | instance IsStdMethod HTTP.DELETE where 65 | toStdMethod = const HTTP.DELETE 66 | instance IsStdMethod HTTP.TRACE where 67 | toStdMethod = const HTTP.TRACE 68 | instance IsStdMethod HTTP.CONNECT where 69 | toStdMethod = const HTTP.CONNECT 70 | instance IsStdMethod HTTP.OPTIONS where 71 | toStdMethod = const HTTP.OPTIONS 72 | instance IsStdMethod HTTP.PATCH where 73 | toStdMethod = const HTTP.PATCH 74 | 75 | -- | A middleware to check whether the request has a specified HTTP 76 | -- method. 77 | -- 78 | -- Typically this would be used with a type application such as: 79 | -- 80 | -- > method @GET handler 81 | -- 82 | -- It is also idiomatic to use the template haskell quasiquoter 83 | -- 'WebGear.Middlewares.Path.match' in cases where both HTTP method 84 | -- and path needs to be matched. 85 | method :: forall t m req a. (IsStdMethod t, MonadRouter m) 86 | => RequestMiddleware' m req (Method t:req) a 87 | method handler = Kleisli $ probe Method >=> either (const rejectRoute) (runKleisli handler) 88 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/users/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Control.Monad (replicateM_, when) 7 | import Criterion.Main (bench, defaultMain, nfIO) 8 | import Data.ByteString (ByteString) 9 | import Data.IORef (newIORef, readIORef, writeIORef) 10 | import Network.HTTP.Types (methodDelete, methodGet, methodPut, statusCode) 11 | import Network.Wai (Application, defaultRequest) 12 | import Network.Wai.Internal (Request (..), Response (..), ResponseReceived (..)) 13 | import System.Environment (getArgs) 14 | 15 | import qualified Network.Wai.Handler.Warp as Warp 16 | 17 | import qualified Scotty 18 | import qualified Servant 19 | import qualified WebGear 20 | 21 | import Model (newStore) 22 | 23 | 24 | main :: IO () 25 | main = do 26 | store <- newStore 27 | getArgs >>= \case 28 | ["webgear"] -> Warp.run 3000 (WebGear.application store) 29 | ["servant"] -> Warp.run 3000 (Servant.application store) 30 | ["scotty"] -> Scotty.application store >>= Warp.run 3000 31 | _ -> runCriterion 32 | 33 | runCriterion :: IO () 34 | runCriterion = do 35 | store <- newStore 36 | defaultMain [ bench "webgear" $ nfIO (runTest $ WebGear.application store) 37 | , bench "servant" $ nfIO (runTest $ Servant.application store) 38 | , bench "scotty" $ nfIO (Scotty.application store >>= runTest) 39 | ] 40 | 41 | runTest :: Application -> IO () 42 | runTest app = replicateM_ 500 $ do 43 | _ <- putRequest >>= flip app (respond 200) 44 | _ <- app getRequest (respond 200) 45 | _ <- app deleteRequest (respond 204) 46 | return () 47 | 48 | putRequest :: IO Request 49 | putRequest = do 50 | f <- bodyGetter "{\"userId\": 1, \"userName\": \"John Doe\", \"dateOfBirth\": \"2000-03-01\", \"gender\": \"Male\", \"emailAddress\": \"john@example.com\"}" 51 | return defaultRequest 52 | { requestMethod = methodPut 53 | , requestHeaders = [("Content-type", "application/json")] 54 | , pathInfo = ["v1", "users", "1"] 55 | , requestBody = f 56 | } 57 | 58 | bodyGetter :: ByteString -> IO (IO ByteString) 59 | bodyGetter s = do 60 | ref <- newIORef (Just s) 61 | pure $ readIORef ref >>= \case 62 | Nothing -> pure "" 63 | Just x -> writeIORef ref Nothing >> return x 64 | 65 | getRequest :: Request 66 | getRequest = defaultRequest 67 | { requestMethod = methodGet 68 | , pathInfo = ["v1", "users", "1"] 69 | } 70 | 71 | deleteRequest :: Request 72 | deleteRequest = defaultRequest 73 | { requestMethod = methodDelete 74 | , pathInfo = ["v1", "users", "1"] 75 | } 76 | 77 | respond :: Int -> Response -> IO ResponseReceived 78 | respond expectedStatus res = do 79 | let actualStatus = statusOf res 80 | when (expectedStatus /= actualStatus) $ 81 | putStrLn "Unexpected response status" 82 | return ResponseReceived 83 | 84 | statusOf :: Response -> Int 85 | statusOf (ResponseFile status _ _ _) = statusCode status 86 | statusOf (ResponseBuilder status _ _) = statusCode status 87 | statusOf (ResponseStream status _ _) = statusCode status 88 | statusOf (ResponseRaw _ res) = statusOf res 89 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Comment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | module Model.Comment 6 | ( CreateCommentPayload (..) 7 | , CommentRecord (..) 8 | , create 9 | , list 10 | , Model.Comment.delete 11 | ) where 12 | 13 | import Data.Aeson 14 | import Data.Maybe (fromJust) 15 | import Data.Time.Clock (UTCTime) 16 | import Data.Time.Clock.POSIX (getCurrentTime) 17 | import Database.Esqueleto as E 18 | import qualified Database.Persist.Sql as DB 19 | import Model.Common 20 | import Model.Entities 21 | import qualified Model.Profile as Profile 22 | import Relude 23 | 24 | 25 | newtype CreateCommentPayload = CreateCommentPayload 26 | { commentBody :: Text } 27 | deriving (Generic) 28 | 29 | instance FromJSON CreateCommentPayload where 30 | parseJSON = genericParseJSON dropPrefixOptions 31 | 32 | data CommentRecord = CommentRecord 33 | { commentId :: Int64 34 | , commentCreatedAt :: UTCTime 35 | , commentUpdatedAt :: UTCTime 36 | , commentBody :: Text 37 | , commentAuthor :: Maybe Profile.Profile 38 | } 39 | deriving (Generic) 40 | 41 | instance ToJSON CommentRecord where 42 | toJSON = genericToJSON dropPrefixOptions 43 | 44 | create :: Key User -> Text -> CreateCommentPayload -> DBAction (Maybe CommentRecord) 45 | create commentAuthor slug CreateCommentPayload{..} = 46 | getArticleIdBySlug slug >>= traverse doCreate 47 | where 48 | doCreate :: Key Article -> DBAction CommentRecord 49 | doCreate commentArticle = do 50 | commentCreatedAt <- liftIO getCurrentTime 51 | let commentUpdatedAt = commentCreatedAt 52 | commentId <- DB.insert Comment{..} 53 | fromJust <$> getCommentRecord (Just commentAuthor) commentId 54 | 55 | getArticleIdBySlug :: Text -> DBAction (Maybe (Key Article)) 56 | getArticleIdBySlug slug = fmap unValue . listToMaybe <$> 57 | (select $ from $ 58 | \article -> do 59 | where_ (article ^. ArticleSlug ==. val slug) 60 | pure $ article ^. ArticleId) 61 | 62 | getCommentRecord :: Maybe (Key User) -> Key Comment -> DBAction (Maybe CommentRecord) 63 | getCommentRecord maybeUserId commentId = DB.get commentId >>= traverse mkRecord 64 | where 65 | mkRecord :: Comment -> DBAction CommentRecord 66 | mkRecord Comment{..} = do 67 | authorProfile <- Profile.getOne maybeUserId commentAuthor 68 | pure CommentRecord 69 | { commentId = DB.fromSqlKey commentId 70 | , commentAuthor = authorProfile 71 | , .. 72 | } 73 | 74 | 75 | -------------------------------------------------------------------------------- 76 | 77 | list :: Maybe (Key User) -> Text -> DBAction [CommentRecord] 78 | list maybeCurrentUserId slug = do 79 | commentIds <- select $ from $ 80 | \(article, comment) -> do 81 | where_ (article ^. ArticleId ==. comment ^. CommentArticle) 82 | where_ (article ^. ArticleSlug ==. val slug) 83 | pure $ comment ^. CommentId 84 | comments <- traverse (getCommentRecord maybeCurrentUserId . unValue) commentIds 85 | pure $ catMaybes comments 86 | 87 | 88 | -------------------------------------------------------------------------------- 89 | 90 | delete :: Key User -> Text -> Key Comment -> DBAction () 91 | delete authorId slug commentId = E.delete $ from $ 92 | \comment -> do 93 | where_ (comment ^. CommentId ==. val commentId) 94 | where_ (comment ^. CommentAuthor ==. val authorId) 95 | where_ $ exists $ from $ 96 | \article -> do 97 | where_ (comment ^. CommentArticle ==. article ^. ArticleId) 98 | where_ (article ^. ArticleSlug ==. val slug) 99 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | module API.User 9 | ( create 10 | , login 11 | , current 12 | , update 13 | ) where 14 | 15 | import API.Common 16 | import Control.Exception.Safe (catch) 17 | import qualified Database.Sqlite as DB 18 | import qualified Model.User as Model 19 | import Relude 20 | import WebGear 21 | 22 | 23 | type CreateUserRequest = Wrapped "user" Model.CreateUserPayload 24 | type UserResponse = Wrapped "user" Model.UserRecord 25 | 26 | create :: Handler' App req LByteString 27 | create = jsonRequestBody @CreateUserRequest 28 | $ jsonResponseBody @UserResponse 29 | $ handler 30 | where 31 | handler = Kleisli $ \request -> do 32 | let userPayload = pick @(JSONBody CreateUserRequest) $ from request 33 | jwk <- askJWK 34 | let doCreate = do 35 | user <- runDBAction $ Model.create jwk (unwrap userPayload) 36 | pure $ ok200 $ Wrapped user 37 | doCreate `catch` handleDBError 38 | 39 | handleDBError :: DB.SqliteException -> App (Response a) 40 | handleDBError e | DB.seError e == DB.ErrorConstraint = errorResponse $ badRequest400 "Another user account exists with these values" 41 | | otherwise = errorResponse $ internalServerError500 $ fromString $ show e 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | 47 | type LoginUserRequest = Wrapped "user" Model.LoginUserPayload 48 | 49 | login :: Handler' App req LByteString 50 | login = jsonRequestBody @LoginUserRequest 51 | $ jsonResponseBody @UserResponse 52 | $ handler 53 | where 54 | handler = Kleisli $ \request -> do 55 | let loginPayload = pick @(JSONBody LoginUserRequest) $ from request 56 | jwk <- askJWK 57 | maybeUser <- runDBAction $ Model.checkCredentials jwk (unwrap loginPayload) 58 | maybe forbidden (pure . ok200 . Wrapped) maybeUser 59 | 60 | forbidden = errorResponse $ forbidden403 "Invalid credentials" 61 | 62 | 63 | -------------------------------------------------------------------------------- 64 | 65 | current :: Handler' App req LByteString 66 | current = requiredTokenAuth 67 | $ jsonResponseBody @UserResponse 68 | $ handler 69 | where 70 | handler :: HasTrait RequiredAuth req => Handler' App req UserResponse 71 | handler = Kleisli $ \request -> do 72 | let userId = pick @RequiredAuth $ from request 73 | jwk <- askJWK 74 | maybeUser <- runDBAction $ Model.getByKey jwk userId 75 | pure $ maybe notFound404 (ok200 . Wrapped) maybeUser 76 | 77 | 78 | -------------------------------------------------------------------------------- 79 | 80 | type UpdateUserRequest = Wrapped "user" Model.UpdateUserPayload 81 | 82 | update :: Handler' App req LByteString 83 | update = requiredTokenAuth 84 | $ jsonRequestBody @UpdateUserRequest 85 | $ jsonResponseBody @UserResponse 86 | $ handler 87 | where 88 | handler :: HaveTraits [RequiredAuth, JSONBody UpdateUserRequest] req => Handler' App req UserResponse 89 | handler = Kleisli $ \request -> do 90 | let userId = pick @RequiredAuth $ from request 91 | userPayload = pick @(JSONBody UpdateUserRequest) $ from request 92 | jwk <- askJWK 93 | let doUpdate = do 94 | maybeUser <- runDBAction $ Model.update jwk userId (unwrap userPayload) 95 | pure $ maybe notFound404 (ok200 . Wrapped) maybeUser 96 | doUpdate `catch` handleDBError 97 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | branches: [master] 8 | 9 | jobs: 10 | stack-build: 11 | name: Stack - ghc-${{ matrix.ghc }} os-${{ matrix.os }} 12 | 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | matrix: 16 | os: 17 | - ubuntu-latest 18 | - macos-latest 19 | ghc: 20 | - 8.10.4 21 | - 8.8.4 22 | - 8.6.5 23 | exclude: 24 | - os: macos-latest 25 | ghc: 8.8.4 26 | - os: macos-latest 27 | ghc: 8.6.5 28 | 29 | env: 30 | STACK_YAML: stack-${{ matrix.ghc }}.yaml 31 | 32 | steps: 33 | - uses: actions/checkout@v2 34 | name: Checkout Source Code 35 | 36 | - uses: haskell/actions/setup@v1 37 | name: Setup Haskell Build Environment 38 | with: 39 | ghc-version: ${{ matrix.ghc }} 40 | enable-stack: true 41 | 42 | - uses: actions/cache@v2 43 | name: Cache dependencies 44 | with: 45 | path: ~/.stack 46 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack-${{ hashFiles(env.STACK_YAML) }} 47 | 48 | - name: Build 49 | run: | 50 | # Workaround for random errors on macos 51 | rm -rf ~/.stack/setup-exe-src ~/.stack/setup-exe-cache 52 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 53 | 54 | - name: Test 55 | run: stack test --system-ghc --ta '--quickcheck-tests 100000' 56 | 57 | - name: Haddock 58 | run: stack haddock --system-ghc 59 | 60 | - name : Prepare sdist 61 | run: stack sdist --system-ghc 62 | 63 | - name: Upload to Hackage 64 | if: startsWith(github.ref, 'refs/tags/v') 65 | run: | 66 | export HACKAGE_USERNAME="rkaippully" 67 | export HACKAGE_PASSWORD="${{ secrets.HACKAGE_TOKEN }}" 68 | stack upload --system-ghc webgear-server 69 | 70 | cabal-build: 71 | name: Cabal - ghc-${{ matrix.ghc }} os-${{ matrix.os }} 72 | 73 | runs-on: ${{ matrix.os }} 74 | strategy: 75 | matrix: 76 | os: [ubuntu-latest, macos-latest] 77 | ghc: 78 | - 8.10.4 79 | - 8.8.4 80 | - 8.6.5 81 | exclude: 82 | - os: macos-latest 83 | ghc: 8.8.4 84 | - os: macos-latest 85 | ghc: 8.6.5 86 | 87 | env: 88 | CONFIG: "--enable-tests --enable-benchmarks" 89 | 90 | steps: 91 | - uses: actions/checkout@v2 92 | name: Checkout Source Code 93 | 94 | - uses: haskell/actions/setup@v1 95 | name: Setup Haskell Build Environment 96 | with: 97 | ghc-version: ${{ matrix.ghc }} 98 | enable-stack: false 99 | 100 | - name: Update package index 101 | run: cabal update $CONFIG 102 | 103 | - name: Generate freeze file 104 | run: cabal freeze $CONFIG 105 | 106 | - uses: actions/cache@v2 107 | name: Cache dependencies 108 | with: 109 | path: | 110 | ~/.cabal/store 111 | dist-newstyle 112 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal-${{ hashFiles('cabal.project.freeze') }} 113 | restore-keys: | 114 | ${{ runner.os }}-${{ matrix.ghc }}-cabal- 115 | 116 | - name: Build 117 | run: cabal build all --enable-documentation $CONFIG 118 | 119 | - name: Test 120 | run: cabal test all --test-show-details=always --test-options='--quickcheck-tests 100000' $CONFIG 121 | 122 | - name: Haddock 123 | run: cabal haddock all --enable-documentation $CONFIG 124 | 125 | - name: Prepare sdist 126 | run: cabal sdist all 127 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | module Main where 7 | 8 | import qualified API.Article as Article 9 | import qualified API.Comment as Comment 10 | import API.Common (App (..), AppEnv (..)) 11 | import qualified API.Profile as Profile 12 | import qualified API.Tag as Tag 13 | import qualified API.User as User 14 | import qualified Crypto.JWT as JWT 15 | import Data.Aeson (eitherDecode) 16 | import qualified Data.ByteString.Lazy as LBS 17 | import Data.Pool (Pool) 18 | import Database.Persist.Sql (SqlBackend) 19 | import Model.Common (withDBConnectionPool) 20 | import Network.HTTP.Types (StdMethod (..)) 21 | import qualified Network.Wai as Wai 22 | import qualified Network.Wai.Handler.Warp as Warp 23 | import Relude 24 | import WebGear 25 | 26 | 27 | -------------------------------------------------------------------------------- 28 | -- A medium.com clone app specified by https://github.com/gothinkster/realworld 29 | -------------------------------------------------------------------------------- 30 | 31 | allRoutes :: Handler' App '[] LByteString 32 | allRoutes = 33 | [route| POST /api/users |] User.create 34 | <|> [route| POST /api/users/login |] User.login 35 | <|> [route| GET /api/user |] User.current 36 | <|> [route| PUT /api/user |] User.update 37 | <|> [route| GET /api/profiles/username:Text |] Profile.getByName 38 | <|> [route| POST /api/profiles/username:Text/follow |] Profile.follow 39 | <|> [route| DELETE /api/profiles/username:Text/follow |] Profile.unfollow 40 | <|> [route| POST /api/articles |] Article.create 41 | <|> [route| GET /api/articles |] Article.list 42 | <|> [route| GET /api/articles/feed |] Article.feed 43 | <|> [route| GET /api/articles/slug:Text |] Article.getBySlug 44 | <|> [route| PUT /api/articles/slug:Text |] Article.update 45 | <|> [route| DELETE /api/articles/slug:Text |] Article.delete 46 | <|> [route| POST /api/articles/slug:Text/favorite |] Article.favorite 47 | <|> [route| DELETE /api/articles/slug:Text/favorite |] Article.unfavorite 48 | <|> [route| POST /api/articles/slug:Text/comments |] Comment.create 49 | <|> [route| GET /api/articles/slug:Text/comments |] Comment.list 50 | <|> [route| DELETE /api/articles/slug:Text/comments/commentId:Int64 |] Comment.delete 51 | <|> [route| GET /api/tags |] Tag.list 52 | 53 | -- UI resources 54 | <|> [match| GET /ui/assets |] serveUIAssets 55 | <|> [match| GET /ui |] serveIndex 56 | <|> [route| GET / |] serveIndex 57 | 58 | serveUIAssets :: Handler' App req LByteString 59 | serveUIAssets = serveDir "ui/assets" Nothing 60 | 61 | serveIndex :: Handler' App req LByteString 62 | serveIndex = Kleisli $ const $ serveFile "ui/index.html" 63 | 64 | application :: Pool SqlBackend -> JWT.JWK -> Wai.Application 65 | application pool jwk = toApplication $ transform appToRouter allRoutes 66 | where 67 | appToRouter :: App a -> Router a 68 | appToRouter = flip runReaderT (AppEnv pool jwk) . unApp 69 | 70 | main :: IO () 71 | main = withDBConnectionPool $ \pool -> do 72 | jwkBS <- LBS.readFile "realworld.jwk" 73 | let jwk = either (error . toText) id $ eitherDecode jwkBS 74 | Warp.run 3000 (application pool jwk) 75 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Profile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module Model.Profile 6 | ( Profile (..) 7 | , getOne 8 | , getByName 9 | , follow 10 | , unfollow 11 | ) 12 | where 13 | 14 | import Control.Exception.Safe (catch, throw) 15 | import Data.Aeson (ToJSON (..), genericToJSON) 16 | import Database.Esqueleto 17 | import qualified Database.Persist as DB 18 | import Database.Sqlite (Error (..), SqliteException (..)) 19 | import Model.Common 20 | import Model.Entities 21 | import Relude 22 | 23 | 24 | data Profile = Profile 25 | { userUsername :: Text 26 | , userBio :: Maybe Text 27 | , userImage :: Maybe Text 28 | , userFollowing :: Bool 29 | } 30 | deriving (Generic) 31 | 32 | instance ToJSON Profile where 33 | toJSON = genericToJSON dropPrefixOptions 34 | 35 | getOne :: Maybe (Key User) -- ^ current user (if any) 36 | -> Key User -- ^ user to get profile of 37 | -> DBAction (Maybe Profile) 38 | getOne maybeFollowerKey followeeKey = 39 | findProfile maybeFollowerKey $ 40 | \user -> user ^. UserId ==. val followeeKey 41 | 42 | findProfile :: Maybe (Key User) 43 | -> (SqlExpr (Entity User) -> SqlExpr (Value Bool)) 44 | -> DBAction (Maybe Profile) 45 | findProfile maybeFollowerKey selector = do 46 | maybeResult <- fmap listToMaybe <$> 47 | select $ from $ 48 | \user -> do 49 | where_ (selector user) 50 | pure (user ^. UserId, user ^. UserUsername, user ^. UserBio, user ^. UserImage) 51 | traverse mkProfile maybeResult 52 | where 53 | mkProfile (Value userId, Value userUsername, Value userBio, Value userImage) = do 54 | maybeFollowing <- traverse (isFollowing userId) maybeFollowerKey 55 | pure Profile{userFollowing = fromMaybe False maybeFollowing, ..} 56 | 57 | isFollowing :: Key User -> Key User -> DBAction Bool 58 | isFollowing followeeKey followerKey = do 59 | followCount <- select $ from $ 60 | \flw -> do 61 | where_ (flw ^. FollowFollower ==. val followerKey) 62 | where_ (flw ^. FollowFollowee ==. val followeeKey) 63 | pure (countRows @Int) 64 | pure $ followCount == [Value 1] 65 | 66 | 67 | -------------------------------------------------------------------------------- 68 | 69 | getByName :: Maybe (Key User) -- ^ current user (if any) 70 | -> Text -- ^ username to get profile of 71 | -> DBAction (Maybe Profile) 72 | getByName maybeFollowerKey username = 73 | findProfile maybeFollowerKey $ 74 | \user -> user ^. UserUsername ==. val username 75 | 76 | 77 | -------------------------------------------------------------------------------- 78 | 79 | follow :: Key User -> Text -> DBAction (Maybe Profile) 80 | follow followerKey followeeUsername = getUserIdByName followeeUsername >>= \case 81 | Nothing -> pure Nothing 82 | Just followeeKey -> do 83 | let flw = Follow{followFollower = followerKey, followFollowee = followeeKey} 84 | let handleDBError :: SqliteException -> DBAction () 85 | handleDBError e | seError e == ErrorConstraint = pure () 86 | | otherwise = throw e 87 | DB.insert_ flw `catch` handleDBError 88 | getOne (Just followerKey) followeeKey 89 | 90 | getUserIdByName :: Text -> DBAction (Maybe (Key User)) 91 | getUserIdByName name = do 92 | result <- select $ from $ 93 | \user -> do 94 | where_ (user ^. UserUsername ==. val name) 95 | pure (user ^. UserId) 96 | pure $ unValue <$> listToMaybe result 97 | 98 | 99 | -------------------------------------------------------------------------------- 100 | 101 | unfollow :: Key User -> Text -> DBAction (Maybe Profile) 102 | unfollow followerKey followeeUsername = getUserIdByName followeeUsername >>= \case 103 | Nothing -> pure Nothing 104 | Just followeeKey -> do 105 | DB.deleteBy (UniqueFollow followerKey followeeKey) 106 | getOne (Just followerKey) followeeKey 107 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | module API.Common where 13 | 14 | import Control.Exception.Safe (MonadCatch, MonadThrow) 15 | import Control.Lens (view) 16 | import Control.Monad.Except (MonadError) 17 | import Control.Monad.Time (MonadTime (..)) 18 | import qualified Crypto.JWT as JWT 19 | import Data.Aeson 20 | import Data.Pool (Pool) 21 | import Database.Persist.Sql (runSqlPool, toSqlKey) 22 | import Database.Persist.Sqlite (SqlBackend) 23 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 24 | import Model.Common (DBAction) 25 | import Model.Entities (Key, User) 26 | import Relude 27 | import WebGear 28 | 29 | 30 | -- The API handlers run in the App monad. 31 | 32 | data AppEnv = AppEnv 33 | { appEnvSqlBackend :: Pool SqlBackend 34 | , appEnvJWK :: JWT.JWK 35 | } 36 | 37 | newtype App a = App { unApp :: ReaderT AppEnv Router a } 38 | deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadThrow, MonadCatch 39 | , MonadReader AppEnv, MonadError RouteError, MonadState PathInfo, MonadIO) 40 | 41 | instance MonadRouter App where 42 | rejectRoute = App $ lift rejectRoute 43 | errorResponse = App . lift . errorResponse 44 | catchErrorResponse (App (ReaderT action)) handler = App $ ReaderT $ \r -> 45 | catchErrorResponse (action r) (flip runReaderT r . unApp . handler) 46 | 47 | instance MonadTime App where 48 | currentTime = liftIO currentTime 49 | 50 | instance JWT.MonadRandom App where 51 | getRandomBytes = liftIO . JWT.getRandomBytes 52 | 53 | askConnectionPool :: MonadReader AppEnv m => m (Pool SqlBackend) 54 | askConnectionPool = asks appEnvSqlBackend 55 | 56 | askJWK :: MonadReader AppEnv m => m JWT.JWK 57 | askJWK = asks appEnvJWK 58 | 59 | runDBAction :: DBAction a -> App a 60 | runDBAction action = do 61 | pool <- askConnectionPool 62 | liftIO $ runSqlPool action pool 63 | 64 | 65 | -------------------------------------------------------------------------------- 66 | 67 | -- Middlewares for JWT authentication with "token" scheme 68 | 69 | type RequiredAuth = JWTAuth' Required "token" App () (Key User) 70 | type OptionalAuth = JWTAuth' Optional "token" App () (Key User) 71 | 72 | requiredTokenAuth :: RequestMiddleware' App req (RequiredAuth : req) a 73 | requiredTokenAuth = tokenAuth jwtAuth' 74 | 75 | optionalTokenAuth :: RequestMiddleware' App req (OptionalAuth : req) a 76 | optionalTokenAuth = tokenAuth optionalJWTAuth' 77 | 78 | tokenAuth :: (JWTAuthConfig App () (Key User) -> RequestMiddleware' App req (r:req) a) 79 | -> RequestMiddleware' App req (r:req) a 80 | tokenAuth auth handler = Kleisli $ \request -> do 81 | jwk <- askJWK 82 | let handler' = auth JWTAuthConfig{jwkSet = JWT.JWKSet [jwk], ..} handler 83 | runKleisli handler' request 84 | where 85 | jwtAuthRealm = "realworld" 86 | jwtValidationSettings = JWT.defaultJWTValidationSettings $ const True 87 | 88 | toJWTAttribute :: JWT.ClaimsSet -> App (Either () (Key User)) 89 | toJWTAttribute claims = pure $ 90 | case view JWT.claimSub claims >>= readMaybe . toString . view JWT.string of 91 | Nothing -> Left () 92 | Just oid -> Right $ toSqlKey oid 93 | 94 | 95 | -------------------------------------------------------------------------------- 96 | 97 | -- A "wrapped" json body. Realworld API spec consumes and returns JSON 98 | -- objects wrapped under a key in a top level object. The @Wrapped@ 99 | -- type encodes/decodes such objects. 100 | 101 | newtype Wrapped (s :: Symbol) t = Wrapped { unwrap :: t } 102 | 103 | instance (KnownSymbol s, FromJSON t) => FromJSON (Wrapped s t) where 104 | parseJSON = withObject "json object" $ \obj -> 105 | Wrapped <$> obj .: fromString (symbolVal $ Proxy @s) 106 | 107 | instance (KnownSymbol s, ToJSON t) => ToJSON (Wrapped s t) where 108 | toJSON (Wrapped x) = object [fromString (symbolVal $ Proxy @s) .= toJSON x] 109 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE OverloadedLists #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | module Model.User 9 | ( CreateUserPayload (..) 10 | , UserRecord (..) 11 | , create 12 | , LoginUserPayload (..) 13 | , checkCredentials 14 | , getByKey 15 | , UpdateUserPayload (..) 16 | , Model.User.update 17 | ) where 18 | 19 | import qualified Crypto.Hash as Hash 20 | import qualified Crypto.JWT as JWT 21 | import Data.Aeson 22 | import Database.Esqueleto as E 23 | import qualified Database.Persist.Sql as DB 24 | import Model.Common 25 | import Model.Entities 26 | import Relude 27 | import WebGear (mkJWT) 28 | 29 | 30 | data CreateUserPayload = CreateUserPayload 31 | { userUsername :: Text 32 | , userEmail :: Text 33 | , userPassword :: Text 34 | } 35 | deriving (Generic) 36 | 37 | data UserRecord = UserRecord 38 | { userId :: Int64 39 | , userUsername :: Text 40 | , userEmail :: Text 41 | , userBio :: Maybe Text 42 | , userImage :: Maybe Text 43 | , userToken :: Text 44 | } 45 | deriving (Generic) 46 | 47 | instance FromJSON CreateUserPayload where 48 | parseJSON = genericParseJSON dropPrefixOptions 49 | 50 | instance ToJSON UserRecord where 51 | toJSON = genericToJSON dropPrefixOptions 52 | 53 | create :: JWT.JWK -> CreateUserPayload -> DBAction UserRecord 54 | create jwk CreateUserPayload{..} = do 55 | let userBio = Nothing 56 | userImage = Nothing 57 | key <- DB.insert User{userPassword = hashUserPassword userPassword, ..} 58 | userToken <- generateJWT jwk key 59 | pure UserRecord{userId = DB.fromSqlKey key, ..} 60 | 61 | hashUserPassword :: Text -> Text 62 | hashUserPassword = show . Hash.hashWith Hash.SHA256 . (encodeUtf8 :: Text -> ByteString) 63 | 64 | generateJWT :: JWT.JWK -> Key User -> DBAction Text 65 | generateJWT jwk uid = do 66 | Right jwt <- mkJWT jwk ["sub" .= show @Text (DB.fromSqlKey uid)] 67 | pure $ decodeUtf8 $ toStrict $ JWT.encodeCompact jwt 68 | 69 | 70 | -------------------------------------------------------------------------------- 71 | 72 | data LoginUserPayload = LoginUserPayload 73 | { email :: Text 74 | , password :: Text 75 | } 76 | deriving (Generic, FromJSON) 77 | 78 | checkCredentials :: JWT.JWK -> LoginUserPayload -> DBAction (Maybe UserRecord) 79 | checkCredentials jwk LoginUserPayload{..} = do 80 | users <- select $ from $ 81 | \u -> do 82 | where_ (u ^. UserEmail ==. val email) 83 | where_ (u ^. UserPassword ==. val (hashUserPassword password)) 84 | pure u 85 | case users of 86 | [Entity key User{..}] -> do 87 | userToken <- generateJWT jwk key 88 | pure $ Just $ UserRecord{userId = DB.fromSqlKey key, ..} 89 | _ -> pure Nothing 90 | 91 | 92 | -------------------------------------------------------------------------------- 93 | 94 | getByKey :: JWT.JWK -> Key User -> DBAction (Maybe UserRecord) 95 | getByKey jwk key = DB.get key >>= traverse mkRecord 96 | where 97 | mkRecord User{..} = do 98 | userToken <- generateJWT jwk key 99 | pure UserRecord{userId = DB.fromSqlKey key, ..} 100 | 101 | 102 | -------------------------------------------------------------------------------- 103 | 104 | data UpdateUserPayload = UpdateUserPayload 105 | { userUsername :: Maybe Text 106 | , userEmail :: Maybe Text 107 | , userPassword :: Maybe Text 108 | , userBio :: Maybe (Maybe Text) 109 | , userImage :: Maybe (Maybe Text) 110 | } 111 | deriving (Generic) 112 | 113 | instance FromJSON UpdateUserPayload where 114 | parseJSON = genericParseJSON dropPrefixOptions 115 | 116 | update :: JWT.JWK -> Key User -> UpdateUserPayload -> DBAction (Maybe UserRecord) 117 | update jwk key UpdateUserPayload{..} = do 118 | let updates = catMaybes [ UserUsername =?. userUsername 119 | , UserEmail =?. userEmail 120 | , UserPassword =?. (hashUserPassword <$> userPassword) 121 | , UserBio =?. userBio 122 | , UserImage =?. userImage 123 | ] 124 | E.update $ \u -> do 125 | set u updates 126 | where_ (u ^. UserId ==. val key) 127 | getByKey jwk key 128 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/users/WebGear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | module WebGear where 12 | 13 | import Control.Applicative (Alternative (..)) 14 | import Control.Arrow (Kleisli (..)) 15 | import Control.Monad (MonadPlus) 16 | import Control.Monad.Except (MonadError) 17 | import Control.Monad.IO.Class (MonadIO (..)) 18 | import Control.Monad.Reader (MonadReader (..), ReaderT (..)) 19 | import Control.Monad.State.Strict (MonadState) 20 | import Control.Monad.Trans (lift) 21 | import Data.ByteString.Lazy (ByteString) 22 | import Model 23 | import Network.HTTP.Types (StdMethod (..)) 24 | import Network.Wai (Application) 25 | import WebGear.Middlewares 26 | import WebGear.Trait 27 | import WebGear.Types 28 | 29 | 30 | -------------------------------------------------------------------------------- 31 | -- Routes of the API 32 | -------------------------------------------------------------------------------- 33 | type IntUserId = PathVar "userId" Int 34 | 35 | -- The route handlers run in the App monad 36 | newtype App a = App { unApp :: ReaderT UserStore Router a } 37 | deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus 38 | , MonadIO , MonadReader UserStore, MonadError RouteError, MonadState PathInfo) 39 | 40 | instance MonadRouter App where 41 | rejectRoute = App $ lift rejectRoute 42 | errorResponse = App . lift . errorResponse 43 | catchErrorResponse (App (ReaderT action)) handler = App $ ReaderT $ \r -> 44 | catchErrorResponse (action r) (flip runReaderT r . unApp . handler) 45 | 46 | userRoutes :: Handler' App '[] ByteString 47 | userRoutes = [match| /v1/users/userId:Int |] -- non-TH version: path @"/v1/users" . pathVar @"userId" @Int 48 | $ getUser <|> putUser <|> deleteUser 49 | 50 | getUser :: HasTrait IntUserId req => Handler' App req ByteString 51 | getUser = method @GET 52 | $ jsonResponseBody @User 53 | $ getUserHandler 54 | 55 | putUser :: HasTrait IntUserId req => Handler' App req ByteString 56 | putUser = method @PUT 57 | $ requestContentTypeHeader @"application/json" 58 | $ jsonRequestBody @User 59 | $ jsonResponseBody @User 60 | $ putUserHandler 61 | 62 | deleteUser :: HasTrait IntUserId req => Handler' App req ByteString 63 | deleteUser = method @DELETE deleteUserHandler 64 | 65 | getUserHandler :: ( MonadReader UserStore m 66 | , MonadIO m 67 | , HasTrait IntUserId req 68 | ) 69 | => Handler' m req User 70 | getUserHandler = Kleisli $ \request -> do 71 | let uid = pick @IntUserId $ from request 72 | store <- ask 73 | user <- lookupUser store (UserId uid) 74 | pure $ maybe notFound404 ok200 user 75 | 76 | putUserHandler :: ( MonadReader UserStore m 77 | , MonadIO m 78 | , HaveTraits [IntUserId, JSONBody User] req 79 | ) 80 | => Handler' m req User 81 | putUserHandler = Kleisli $ \request -> do 82 | let uid = pick @IntUserId $ from request 83 | user = pick @(JSONBody User) $ from request 84 | user' = user { userId = UserId uid } 85 | store <- ask 86 | addUser store user' 87 | pure $ ok200 user' 88 | 89 | deleteUserHandler :: ( MonadReader UserStore m 90 | , MonadIO m 91 | , HasTrait IntUserId req 92 | ) 93 | => Handler' m req ByteString 94 | deleteUserHandler = Kleisli $ \request -> do 95 | let uid = pick @IntUserId $ from request 96 | store <- ask 97 | found <- removeUser store (UserId uid) 98 | pure $ if found then noContent204 else notFound404 99 | 100 | 101 | -------------------------------------------------------------------------------- 102 | -- | The application server 103 | -------------------------------------------------------------------------------- 104 | application :: UserStore -> Application 105 | application store = toApplication $ transform appToRouter userRoutes 106 | where 107 | appToRouter :: App a -> Router a 108 | appToRouter = flip runReaderT store . unApp 109 | -------------------------------------------------------------------------------- /webgear-benchmarks/results/bench-ab-users.txt: -------------------------------------------------------------------------------- 1 | WebGear Results 2 | =============== 3 | 4 | This is ApacheBench, Version 2.3 <$Revision: 1843412 $> 5 | Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/ 6 | Licensed to The Apache Software Foundation, http://www.apache.org/ 7 | 8 | Benchmarking localhost (be patient) 9 | 10 | 11 | Server Software: WebGear/0.1.0 12 | Server Hostname: localhost 13 | Server Port: 3000 14 | 15 | Document Path: /v1/users/1 16 | Document Length: 111 bytes 17 | 18 | Concurrency Level: 3 19 | Time taken for tests: 7.091 seconds 20 | Complete requests: 50000 21 | Failed requests: 0 22 | Keep-Alive requests: 0 23 | Total transferred: 11100000 bytes 24 | Total body sent: 14500000 25 | HTML transferred: 5550000 bytes 26 | Requests per second: 7051.59 [#/sec] (mean) 27 | Time per request: 0.425 [ms] (mean) 28 | Time per request: 0.142 [ms] (mean, across all concurrent requests) 29 | Transfer rate: 1528.76 [Kbytes/sec] received 30 | 1997.03 kb/s sent 31 | 3525.80 kb/s total 32 | 33 | Connection Times (ms) 34 | min mean[+/-sd] median max 35 | Connect: 0 0 0.1 0 7 36 | Processing: 0 0 1.3 0 124 37 | Waiting: 0 0 1.3 0 124 38 | Total: 0 0 1.3 0 125 39 | 40 | Percentage of the requests served within a certain time (ms) 41 | 50% 0 42 | 66% 0 43 | 75% 0 44 | 80% 0 45 | 90% 1 46 | 95% 1 47 | 98% 3 48 | 99% 4 49 | 100% 125 (longest request) 50 | 51 | 52 | Servant Results 53 | =============== 54 | 55 | This is ApacheBench, Version 2.3 <$Revision: 1843412 $> 56 | Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/ 57 | Licensed to The Apache Software Foundation, http://www.apache.org/ 58 | 59 | Benchmarking localhost (be patient) 60 | 61 | 62 | Server Software: Warp/3.3.13 63 | Server Hostname: localhost 64 | Server Port: 3000 65 | 66 | Document Path: /v1/users/1 67 | Document Length: 111 bytes 68 | 69 | Concurrency Level: 3 70 | Time taken for tests: 6.219 seconds 71 | Complete requests: 50000 72 | Failed requests: 0 73 | Keep-Alive requests: 0 74 | Total transferred: 11700000 bytes 75 | Total body sent: 14500000 76 | HTML transferred: 5550000 bytes 77 | Requests per second: 8039.39 [#/sec] (mean) 78 | Time per request: 0.373 [ms] (mean) 79 | Time per request: 0.124 [ms] (mean, across all concurrent requests) 80 | Transfer rate: 1837.13 [Kbytes/sec] received 81 | 2276.78 kb/s sent 82 | 4113.90 kb/s total 83 | 84 | Connection Times (ms) 85 | min mean[+/-sd] median max 86 | Connect: 0 0 0.0 0 6 87 | Processing: 0 0 0.7 0 22 88 | Waiting: 0 0 0.7 0 22 89 | Total: 0 0 0.7 0 22 90 | 91 | Percentage of the requests served within a certain time (ms) 92 | 50% 0 93 | 66% 0 94 | 75% 0 95 | 80% 0 96 | 90% 0 97 | 95% 0 98 | 98% 2 99 | 99% 4 100 | 100% 22 (longest request) 101 | 102 | 103 | Scotty Results 104 | ============== 105 | 106 | This is ApacheBench, Version 2.3 <$Revision: 1843412 $> 107 | Copyright 1996 Adam Twiss, Zeus Technology Ltd, http://www.zeustech.net/ 108 | Licensed to The Apache Software Foundation, http://www.apache.org/ 109 | 110 | Benchmarking localhost (be patient) 111 | 112 | 113 | Server Software: Warp/3.3.13 114 | Server Hostname: localhost 115 | Server Port: 3000 116 | 117 | Document Path: /v1/users/1 118 | Document Length: 111 bytes 119 | 120 | Concurrency Level: 3 121 | Time taken for tests: 6.222 seconds 122 | Complete requests: 50000 123 | Failed requests: 0 124 | Keep-Alive requests: 0 125 | Total transferred: 11750000 bytes 126 | Total body sent: 14500000 127 | HTML transferred: 5550000 bytes 128 | Requests per second: 8035.73 [#/sec] (mean) 129 | Time per request: 0.373 [ms] (mean) 130 | Time per request: 0.124 [ms] (mean, across all concurrent requests) 131 | Transfer rate: 1844.14 [Kbytes/sec] received 132 | 2275.74 kb/s sent 133 | 4119.88 kb/s total 134 | 135 | Connection Times (ms) 136 | min mean[+/-sd] median max 137 | Connect: 0 0 0.0 0 3 138 | Processing: 0 0 0.7 0 18 139 | Waiting: 0 0 0.7 0 18 140 | Total: 0 0 0.7 0 18 141 | 142 | Percentage of the requests served within a certain time (ms) 143 | 50% 0 144 | 66% 0 145 | 75% 0 146 | 80% 0 147 | 90% 0 148 | 95% 0 149 | 98% 2 150 | 99% 4 151 | 100% 18 (longest request) 152 | -------------------------------------------------------------------------------- /webgear-examples/webgear-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-examples 3 | version: 0.2.1 4 | description: Please see the README at 5 | homepage: https://github.com/rkaippully/webgear/webgear-examples#readme 6 | bug-reports: https://github.com/rkaippully/webgear/issues 7 | author: Raghu Kaippully 8 | maintainer: rkaippully@gmail.com 9 | copyright: 2020 Raghu Kaippully 10 | license: MPL-2.0 11 | license-file: LICENSE 12 | build-type: Simple 13 | extra-source-files: README.md 14 | 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/rkaippully/webgear 19 | 20 | executable hello 21 | default-language: Haskell2010 22 | build-depends: base >=4.12.0.0 && <5 23 | , http-types ==0.12.* 24 | , wai ==3.2.* 25 | , warp ==3.3.* 26 | , webgear-server 27 | ghc-options: -threaded 28 | -rtsopts 29 | -with-rtsopts=-N 30 | -Wall 31 | -Wno-unticked-promoted-constructors 32 | -Wincomplete-record-updates 33 | -Wincomplete-uni-patterns 34 | -Wredundant-constraints 35 | main-is: Main.hs 36 | hs-source-dirs: hello 37 | 38 | executable users 39 | default-language: Haskell2010 40 | build-depends: aeson >=1.4 && <1.6 41 | , base >=4.12.0.0 && <5 42 | , bytestring ==0.10.* 43 | , hashable >=1.2.7.0 && <1.4 44 | , http-types ==0.12.* 45 | , mtl ==2.2.* 46 | , text ==1.2.* 47 | , time >=1.8.0.2 && <1.10 48 | , unordered-containers ==0.2.* 49 | , wai ==3.2.* 50 | , warp ==3.3.* 51 | , webgear-server 52 | ghc-options: -threaded 53 | -rtsopts 54 | -with-rtsopts=-N 55 | -Wall 56 | -Wno-unticked-promoted-constructors 57 | -Wincomplete-record-updates 58 | -Wincomplete-uni-patterns 59 | -Wredundant-constraints 60 | main-is: Main.hs 61 | hs-source-dirs: users 62 | 63 | executable realworld 64 | default-language: Haskell2010 65 | build-depends: aeson >=1.4 && <1.6 66 | , base >=4.12.0.0 && <5 67 | , bytestring ==0.10.* 68 | , cryptonite >=0.25 69 | , esqueleto >=3.0.0 && <3.5 70 | , http-types ==0.12.* 71 | , jose >=0.8.2.0 72 | , lens >=4.17.1 73 | , monad-logger >=0.3.31 && <0.4 74 | , monad-time ==0.3.1.0 75 | , mtl ==2.2.* 76 | , persistent >=2.9.2 && <2.12 77 | , persistent-sqlite >=2.9.3 && <2.12 78 | , persistent-template >=2.6.0 && <2.10 79 | , random ==1.1.* 80 | , relude >=0.5.0 && <0.8 81 | , resource-pool ==0.2.* 82 | , safe-exceptions ==0.1.* 83 | , text ==1.2.* 84 | , time >=1.8.0.2 && <1.10 85 | , uri-encode ==1.5.* 86 | , wai ==3.2.* 87 | , warp ==3.3.* 88 | , webgear-server 89 | default-extensions: NoImplicitPrelude 90 | ghc-options: -threaded 91 | -rtsopts 92 | -with-rtsopts=-N 93 | -Wall 94 | -Wno-unticked-promoted-constructors 95 | -Wincomplete-record-updates 96 | -Wincomplete-uni-patterns 97 | -Wredundant-constraints 98 | hs-source-dirs: realworld 99 | main-is: Main.hs 100 | other-modules: API.Article 101 | , API.Comment 102 | , API.Profile 103 | , API.Tag 104 | , API.User 105 | , API.Common 106 | , Model.Entities 107 | , Model.Article 108 | , Model.Comment 109 | , Model.Profile 110 | , Model.Tag 111 | , Model.User 112 | , Model.Common 113 | 114 | -------------------------------------------------------------------------------- /webgear-server/webgear-server.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-server 3 | version: 0.2.1 4 | synopsis: Composable, type-safe library to build HTTP API servers 5 | description: 6 | WebGear is a library to for building composable, type-safe HTTP API servers. 7 | 8 | WebGear focuses on good documentation and usability. 9 | 10 | See the documentation of WebGear module to get started. 11 | homepage: https://github.com/rkaippully/webgear#readme 12 | bug-reports: https://github.com/rkaippully/webgear/issues 13 | author: Raghu Kaippully 14 | maintainer: rkaippully@gmail.com 15 | copyright: 2020 Raghu Kaippully 16 | license: MPL-2.0 17 | license-file: LICENSE 18 | category: Web 19 | build-type: Simple 20 | extra-source-files: README.md 21 | ChangeLog.md 22 | 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/rkaippully/webgear 27 | 28 | 29 | common webgear-common 30 | default-language: Haskell2010 31 | default-extensions: DataKinds 32 | DeriveFunctor 33 | DerivingStrategies 34 | FlexibleContexts 35 | FlexibleInstances 36 | GeneralizedNewtypeDeriving 37 | InstanceSigs 38 | KindSignatures 39 | LambdaCase 40 | MultiParamTypeClasses 41 | OverloadedStrings 42 | PolyKinds 43 | RankNTypes 44 | RecordWildCards 45 | ScopedTypeVariables 46 | TemplateHaskellQuotes 47 | TypeApplications 48 | TypeFamilies 49 | TypeOperators 50 | build-depends: aeson >=1.4 && <1.6 51 | , base >=4.12.0.0 && <5 52 | , base64-bytestring >=1.0.0.3 && <1.3 53 | , bytestring >=0.10.8.2 && <0.12 54 | , bytestring-conversion ==0.3.* 55 | , case-insensitive ==1.2.* 56 | , filepath ==1.4.* 57 | , http-api-data ==0.4.* 58 | , http-types ==0.12.* 59 | , mtl ==2.2.* 60 | , network >=2.8 && <3.2 61 | , safe-exceptions ==0.1.* 62 | , tagged ==0.8.* 63 | , template-haskell >=2.14.0.0 && <3 64 | , text ==1.2.* 65 | , unordered-containers ==0.2.* 66 | , wai ==3.2.* 67 | ghc-options: -Wall 68 | -Wno-unticked-promoted-constructors 69 | -Wincomplete-record-updates 70 | -Wincomplete-uni-patterns 71 | -Wredundant-constraints 72 | 73 | library 74 | import: webgear-common 75 | exposed-modules: WebGear 76 | , WebGear.Modifiers 77 | , WebGear.Trait 78 | , WebGear.Types 79 | , WebGear.Middlewares 80 | , WebGear.Middlewares.Auth.Basic 81 | , WebGear.Middlewares.Auth.JWT 82 | , WebGear.Middlewares.Auth.Util 83 | , WebGear.Middlewares.Body 84 | , WebGear.Middlewares.Header 85 | , WebGear.Middlewares.Method 86 | , WebGear.Middlewares.Params 87 | , WebGear.Middlewares.Path 88 | , WebGear.Handlers.Static 89 | other-modules: Paths_webgear_server 90 | , WebGear.Util 91 | autogen-modules: Paths_webgear_server 92 | hs-source-dirs: src 93 | build-depends: mime-types ==0.1.* 94 | , monad-time ==0.3.1.0 95 | , jose >=0.8.2.0 && <0.9 96 | 97 | test-suite webgear-server-test 98 | import: webgear-common 99 | type: exitcode-stdio-1.0 100 | main-is: Main.hs 101 | other-modules: Unit 102 | , Unit.Trait.Header 103 | , Unit.Trait.Path 104 | , Properties 105 | , Properties.Trait.Body 106 | , Properties.Trait.Header 107 | , Properties.Trait.Params 108 | , Properties.Trait.Method 109 | , Properties.Trait.Path 110 | , Properties.Trait.Auth.Basic 111 | hs-source-dirs: test 112 | default-extensions: TemplateHaskell 113 | ghc-options: -threaded 114 | -rtsopts 115 | -with-rtsopts=-N 116 | build-depends: QuickCheck >=2.13 && <2.15 117 | , quickcheck-instances ==0.3.* 118 | , tasty >=1.2 && <1.5 119 | , tasty-hunit ==0.10.* 120 | , tasty-quickcheck ==0.10.* 121 | , webgear-server 122 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Trait.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Copyright : (c) Raghu Kaippully, 2020-2021 5 | -- License : MPL-2.0 6 | -- Maintainer : rkaippully@gmail.com 7 | -- 8 | -- Traits are optional attributes associated with a value. For 9 | -- example, a list containing totally ordered values might have a 10 | -- @Maximum@ trait where the associated attribute is the maximum 11 | -- value. This trait exists only if the list is non-empty. The 'Trait' 12 | -- typeclass provides an interface to extract such trait attributes. 13 | -- 14 | -- Traits help to link attributes with values in a type-safe manner. 15 | -- 16 | -- Traits are somewhat similar to [refinement 17 | -- types](https://hackage.haskell.org/package/refined), but allow 18 | -- arbitrary attributes to be associated with a value instead of only 19 | -- a predicate. 20 | -- 21 | module WebGear.Trait 22 | ( -- * Core Types 23 | Trait (..) 24 | , Linked 25 | 26 | -- * Linking values with attributes 27 | , linkzero 28 | , unlink 29 | , probe 30 | , transcribe 31 | 32 | -- * Retrive trait attributes from linked values 33 | , HasTrait (..) 34 | , pick 35 | , HaveTraits 36 | 37 | , MissingTrait 38 | ) where 39 | 40 | import Data.Kind (Constraint, Type) 41 | import Data.Tagged (Tagged (..), untag) 42 | import GHC.TypeLits (ErrorMessage (..), TypeError) 43 | 44 | 45 | -- | A trait is an optional attribute @t@ associated with a value 46 | -- @a@. 47 | class Monad m => Trait (t :: Type) (ts :: [Type]) a m where 48 | -- | Type of the associated attribute when the trait holds for a 49 | -- value 50 | type Attribute t a :: Type 51 | 52 | -- | Type that indicates that the trait does not exist for a 53 | -- value. This could be an error message, parse error etc. 54 | type Absence t a :: Type 55 | 56 | -- | Attempt to deduce the trait attribute from the value @a@. 57 | tryLink :: t -> Linked ts a -> m (Either (Absence t a) (Attribute t a)) 58 | 59 | 60 | type family LinkedAttributes (ts :: [Type]) (a :: Type) where 61 | LinkedAttributes '[] a = () 62 | LinkedAttributes (t:ts) a = (Attribute t a, LinkedAttributes ts a) 63 | 64 | -- | A value linked with a type-level list of traits. 65 | data Linked (ts :: [Type]) a = Linked 66 | { linkAttribute :: !(LinkedAttributes ts a) 67 | , unlink :: !a -- ^ Retrive the value from a linked value 68 | } 69 | 70 | -- | Wrap a value with an empty list of traits. 71 | linkzero :: a -> Linked '[] a 72 | linkzero = Linked () 73 | 74 | -- | Attempt to link an additional trait with an already linked value 75 | -- via the 'toAttribute' operation. This can fail indicating an 76 | -- 'Absence' of the trait. 77 | probe :: forall t ts a m. Trait t ts a m 78 | => t 79 | -> Linked ts a 80 | -> m (Either (Absence t a) (Linked (t:ts) a)) 81 | probe t l@Linked{..} = fmap link <$> tryLink t l 82 | where 83 | link :: Attribute t a -> Linked (t:ts) a 84 | link attr = Linked {linkAttribute = (attr, linkAttribute), ..} 85 | 86 | -- | Reencode one trait to another. 87 | -- 88 | -- Like 'probe', but instead of adding a new trait to the trait list, 89 | -- uses the first trait in the list to probe the presence of a new 90 | -- trait and replaces the old trait with the new one. 91 | transcribe :: forall t2 t1 ts a m. Trait t2 (t1:ts) a m 92 | => t2 93 | -> Linked (t1:ts) a 94 | -> m (Either (Absence t2 a) (Linked (t2:ts) a)) 95 | transcribe t2 l@Linked{..} = fmap link <$> tryLink t2 l 96 | where 97 | link :: Attribute t2 a -> Linked (t2:ts) a 98 | link attr = Linked {linkAttribute = (attr, snd linkAttribute), ..} 99 | 100 | 101 | -- | Constraint that proves that the trait @t@ is present in the list 102 | -- of traits @ts@. 103 | class HasTrait t ts where 104 | -- | Get the attribute associated with @t@ from a linked value 105 | from :: Linked ts a -> Tagged t (Attribute t a) 106 | 107 | instance HasTrait t (t:ts) where 108 | from :: Linked (t:ts) a -> Tagged t (Attribute t a) 109 | from (Linked (lv, _) _) = Tagged lv 110 | 111 | instance {-# OVERLAPPABLE #-} HasTrait t ts => HasTrait t (t':ts) where 112 | from :: Linked (t':ts) a -> Tagged t (Attribute t a) 113 | from l = from $ rightLinked l 114 | where 115 | rightLinked :: Linked (q:qs) b -> Linked qs b 116 | rightLinked (Linked (_, rv) a) = Linked rv a 117 | 118 | -- | Retrieve a trait. 119 | -- 120 | -- @pick@ provides a good DSL to retrieve a trait from a linked value 121 | -- like this: 122 | -- 123 | -- > pick @t $ from val 124 | pick :: Tagged t a -> a 125 | pick = untag 126 | 127 | -- For better type errors 128 | instance TypeError (MissingTrait t) => HasTrait t '[] where 129 | from = undefined 130 | 131 | -- | Type error for nicer UX of missing traits 132 | type MissingTrait t = Text "The request doesn't have the trait ‘" :<>: ShowType t :<>: Text "’." 133 | :$$: Text "" 134 | :$$: Text "Did you use a wrong trait type?" 135 | :$$: Text "For e.g., ‘QueryParam \"foo\" Int’ instead of ‘QueryParam \"foo\" String’?" 136 | :$$: Text "" 137 | :$$: Text "Or did you forget to apply an appropriate middleware?" 138 | :$$: Text "For e.g. The trait ‘JSONRequestBody Foo’ can be used with ‘jsonRequestBody @Foo’ middleware." 139 | :$$: Text "" 140 | 141 | 142 | -- | Constraint that proves that all the traits in the list @ts@ are 143 | -- also present in the list @qs@. 144 | type family HaveTraits ts qs :: Constraint where 145 | HaveTraits '[] qs = () 146 | HaveTraits (t:ts) qs = (HasTrait t qs, HaveTraits ts qs) 147 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Copyright : (c) Raghu Kaippully, 2020-2021 5 | -- License : MPL-2.0 6 | -- Maintainer : rkaippully@gmail.com 7 | -- 8 | -- Basic authentication support. 9 | -- 10 | module WebGear.Middlewares.Auth.Basic 11 | ( BasicAuth' (..) 12 | , BasicAuth 13 | , BasicAuthConfig (..) 14 | , Realm (..) 15 | , Username (..) 16 | , Password (..) 17 | , Credentials (..) 18 | , BasicAuthError (..) 19 | , basicAuth 20 | , optionalBasicAuth 21 | ) where 22 | 23 | import Control.Arrow (Kleisli (..)) 24 | import Control.Monad ((>=>)) 25 | import Control.Monad.Except (MonadError (throwError)) 26 | import Data.Bifunctor (first) 27 | import Data.ByteString (ByteString) 28 | import Data.ByteString.Base64 (decodeLenient) 29 | import Data.ByteString.Char8 (intercalate, split) 30 | import Data.String (IsString) 31 | import Data.Void (Void, absurd) 32 | import WebGear.Middlewares.Auth.Util (AuthToken (..), AuthorizationHeader, Realm (..), 33 | authorizationHeader, respondUnauthorized) 34 | import WebGear.Modifiers (Existence (..)) 35 | import WebGear.Trait (HasTrait (..), Linked, Trait (..), pick, transcribe) 36 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response, forbidden403) 37 | 38 | 39 | -- | Trait for HTTP basic authentication: https://tools.ietf.org/html/rfc7617 40 | newtype BasicAuth' (x :: Existence) m e a = BasicAuth' 41 | { toBasicAttribute :: Credentials -> m (Either e a) 42 | } 43 | 44 | type BasicAuth = BasicAuth' Required 45 | 46 | -- | Username for basic authentication. Valid usernames cannot contain 47 | -- \':\' characters. 48 | newtype Username = Username ByteString 49 | deriving newtype (Eq, Ord, Show, Read, IsString) 50 | 51 | -- | Password for basic authentication. 52 | newtype Password = Password ByteString 53 | deriving newtype (Eq, Ord, Show, Read, IsString) 54 | 55 | -- | Basic authentication credentials retrieved from an HTTP request 56 | data Credentials = Credentials 57 | { credentialsUsername :: !Username 58 | , credentialsPassword :: !Password 59 | } 60 | deriving (Eq, Ord, Show, Read) 61 | 62 | -- | Configuration settings for JWT authentication 63 | data BasicAuthConfig m e a = BasicAuthConfig 64 | { basicAuthRealm :: Realm 65 | , toBasicAttribute :: Credentials -> m (Either e a) 66 | } 67 | 68 | data BasicAuthError e = BasicAuthHeaderMissing 69 | | BasicAuthSchemeMismatch 70 | | BasicAuthCredsBadFormat 71 | | BasicAuthAttributeError e 72 | deriving (Eq, Show, Read) 73 | 74 | parseCreds :: AuthToken "Basic" -> Either (BasicAuthError e) Credentials 75 | parseCreds AuthToken{..} = 76 | case split ':' (decodeLenient authToken) of 77 | [] -> throwError BasicAuthCredsBadFormat 78 | u:ps -> pure $ Credentials (Username u) (Password $ intercalate ":" ps) 79 | 80 | 81 | instance (HasTrait (AuthorizationHeader "Basic") ts, Monad m) => Trait (BasicAuth' Required m e a) ts Request m where 82 | type Attribute (BasicAuth' Required m e a) Request = a 83 | type Absence (BasicAuth' Required m e a) Request = BasicAuthError e 84 | 85 | tryLink :: BasicAuth' Required m e a 86 | -> Linked ts Request 87 | -> m (Either (BasicAuthError e) a) 88 | tryLink BasicAuth'{..} r = 89 | case pick @(AuthorizationHeader "Basic") (from r) of 90 | Nothing -> pure $ Left BasicAuthHeaderMissing 91 | Just (Left _) -> pure $ Left BasicAuthSchemeMismatch 92 | Just (Right token) -> either (pure . Left) validateCreds (parseCreds token) 93 | where 94 | validateCreds :: Credentials -> m (Either (BasicAuthError e) a) 95 | validateCreds creds = first BasicAuthAttributeError <$> toBasicAttribute creds 96 | 97 | instance (HasTrait (AuthorizationHeader "Basic") ts, Monad m) => Trait (BasicAuth' Optional m e a) ts Request m where 98 | type Attribute (BasicAuth' Optional m e a) Request = Either (BasicAuthError e) a 99 | type Absence (BasicAuth' Optional m e a) Request = Void 100 | 101 | tryLink :: BasicAuth' Optional m e a 102 | -> Linked ts Request 103 | -> m (Either Void (Either (BasicAuthError e) a)) 104 | tryLink BasicAuth'{..} r = Right <$> tryLink (BasicAuth'{..} :: BasicAuth' Required m e a) r 105 | 106 | 107 | -- | Middleware to add basic authentication protection for a handler. 108 | -- 109 | -- Example usage: 110 | -- 111 | -- > basicAuth cfg handler 112 | -- 113 | -- This middleware returns a 401 response if no credentials are found 114 | -- in the request. It returns a 403 response if credentials are 115 | -- present but 'toBasicAttribute' failed to convert that to value of type 116 | -- t. 117 | basicAuth :: forall m req e t a. MonadRouter m 118 | => BasicAuthConfig m e t 119 | -> RequestMiddleware' m req (BasicAuth m e t : req) a 120 | basicAuth BasicAuthConfig{..} handler = authorizationHeader @"Basic" $ Kleisli $ 121 | transcribe BasicAuth'{..} >=> either mkError (runKleisli handler) 122 | where 123 | mkError :: BasicAuthError e -> m (Response a) 124 | mkError (BasicAuthAttributeError _) = errorResponse $ forbidden403 "Forbidden" 125 | mkError _ = respondUnauthorized "Basic" basicAuthRealm 126 | 127 | -- | Middleware to add optional basic authentication protection for a handler. 128 | -- 129 | -- Example usage: 130 | -- 131 | -- > optionalBasicAuth cfg handler 132 | -- 133 | -- This middleware will not fail if credentials are invalid or missing 134 | -- in the request. Instead the trait attribute is of type Either 135 | -- 'BasicAuthError' 'Credentials' so that the handler can process the 136 | -- authentication error appropriately. 137 | optionalBasicAuth :: forall m req e t a. MonadRouter m 138 | => BasicAuthConfig m e t 139 | -> RequestMiddleware' m req (BasicAuth' Optional m e t : req) a 140 | optionalBasicAuth BasicAuthConfig{..} handler = authorizationHeader @"Basic" $ Kleisli $ 141 | transcribe BasicAuth'{..} >=> either absurd (runKleisli handler) 142 | -------------------------------------------------------------------------------- /webgear-examples/realworld/API/Article.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | module API.Article 11 | ( create 12 | , getBySlug 13 | , update 14 | , delete 15 | , list 16 | , feed 17 | , favorite 18 | , unfavorite 19 | ) where 20 | 21 | import API.Common 22 | import Control.Exception.Safe (catch) 23 | import Data.Aeson (ToJSON) 24 | import qualified Database.Sqlite as DB 25 | import qualified Model.Article as Model 26 | import Relude 27 | import WebGear hiding (length) 28 | 29 | 30 | type CreateArticleRequest = Wrapped "article" Model.CreateArticlePayload 31 | type ArticleResponse = Wrapped "article" Model.ArticleRecord 32 | 33 | create :: Handler' App req LByteString 34 | create = requiredTokenAuth 35 | $ jsonRequestBody @CreateArticleRequest 36 | $ jsonResponseBody @ArticleResponse 37 | $ handler 38 | where 39 | handler = Kleisli $ \request -> do 40 | let currentUserId = pick @RequiredAuth $ from request 41 | articlePayload = pick @(JSONBody CreateArticleRequest) $ from request 42 | let doCreate = do 43 | article <- runDBAction $ Model.create currentUserId (unwrap articlePayload) 44 | pure $ ok200 $ Wrapped article 45 | doCreate `catch` handleDBError 46 | 47 | handleDBError :: DB.SqliteException -> App (Response a) 48 | handleDBError e | DB.seError e == DB.ErrorConstraint = errorResponse $ badRequest400 "Article already exists" 49 | | otherwise = errorResponse $ internalServerError500 $ fromString $ show e 50 | 51 | 52 | -------------------------------------------------------------------------------- 53 | 54 | getBySlug :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 55 | getBySlug = optionalTokenAuth 56 | $ jsonResponseBody @ArticleResponse 57 | $ handler 58 | where 59 | handler = Kleisli $ \request -> do 60 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 61 | slug = pick @(PathVar "slug" Text) $ from request 62 | maybeArticle <- runDBAction $ Model.getArticleBySlug maybeCurrentUserId slug 63 | pure $ maybe notFound404 (ok200 . Wrapped) maybeArticle 64 | 65 | 66 | -------------------------------------------------------------------------------- 67 | 68 | type UpdateArticleRequest = Wrapped "article" Model.UpdateArticlePayload 69 | 70 | update :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 71 | update = requiredTokenAuth 72 | $ jsonRequestBody @UpdateArticleRequest 73 | $ jsonResponseBody @ArticleResponse 74 | $ handler 75 | where 76 | handler = Kleisli $ \request -> do 77 | let userId = pick @RequiredAuth $ from request 78 | updatePayload = pick @(JSONBody UpdateArticleRequest) $ from request 79 | articleSlug = pick @(PathVar "slug" Text) $ from request 80 | 81 | runDBAction (Model.getArticleIdAndAuthorBySlug articleSlug) >>= \case 82 | Nothing -> pure notFound404 83 | Just (articleId, authorId) 84 | | authorId /= userId -> errorResponse $ forbidden403 "Permission denied" 85 | | otherwise -> do 86 | let doUpdate = do 87 | maybeArticle <- runDBAction $ Model.update authorId articleId (unwrap updatePayload) 88 | pure $ maybe notFound404 (ok200 . Wrapped) maybeArticle 89 | doUpdate `catch` handleDBError 90 | 91 | 92 | -------------------------------------------------------------------------------- 93 | 94 | delete :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 95 | delete = requiredTokenAuth handler 96 | where 97 | handler = Kleisli $ \request -> do 98 | let currentUserId = pick @RequiredAuth $ from request 99 | slug = pick @(PathVar "slug" Text) $ from request 100 | runDBAction $ Model.delete currentUserId slug 101 | pure noContent204 102 | 103 | 104 | -------------------------------------------------------------------------------- 105 | 106 | data ArticleListResponse = ArticleListResponse 107 | { articles :: [Model.ArticleRecord] 108 | , articlesCount :: Int 109 | } 110 | deriving (Generic, ToJSON) 111 | 112 | list :: Handler' App req LByteString 113 | list = optionalTokenAuth 114 | $ optionalQueryParam @"tag" @Text 115 | $ optionalQueryParam @"author" @Text 116 | $ optionalQueryParam @"favorited" @Text 117 | $ optionalQueryParam @"limit" @Int64 118 | $ optionalQueryParam @"offset" @Int64 119 | $ jsonResponseBody @ArticleListResponse 120 | $ handler 121 | where 122 | handler = Kleisli $ \request -> do 123 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 124 | maybeTag = pick @(QueryParam' Optional Strict "tag" Text) $ from request 125 | maybeAuthorName = pick @(QueryParam' Optional Strict "author" Text) $ from request 126 | maybeFavoritedBy = pick @(QueryParam' Optional Strict "favorited" Text) $ from request 127 | listLimit = fromMaybe 20 $ pick @(QueryParam' Optional Strict "limit" Int64) $ from request 128 | listOffset = fromMaybe 0 $ pick @(QueryParam' Optional Strict "offset" Int64) $ from request 129 | 130 | articles <- runDBAction $ Model.articleList Model.ArticleListInput{..} 131 | pure $ ok200 $ ArticleListResponse articles (length articles) 132 | 133 | 134 | -------------------------------------------------------------------------------- 135 | 136 | feed :: Handler' App req LByteString 137 | feed = requiredTokenAuth 138 | $ optionalQueryParam @"limit" @Int64 139 | $ optionalQueryParam @"offset" @Int64 140 | $ jsonResponseBody @ArticleListResponse 141 | $ handler 142 | where 143 | handler = Kleisli $ \request -> do 144 | let currentUserId = pick @RequiredAuth $ from request 145 | listLimit = fromMaybe 20 $ pick @(QueryParam' Optional Strict "limit" Int64) $ from request 146 | listOffset = fromMaybe 0 $ pick @(QueryParam' Optional Strict "offset" Int64) $ from request 147 | 148 | articles <- runDBAction $ Model.articleFeed Model.ArticleFeedInput{..} 149 | pure $ ok200 $ ArticleListResponse articles (length articles) 150 | 151 | 152 | -------------------------------------------------------------------------------- 153 | 154 | favorite :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 155 | favorite = requiredTokenAuth 156 | $ jsonResponseBody @ArticleResponse 157 | $ handler 158 | where 159 | handler = Kleisli $ \request -> do 160 | let currentUserId = pick @RequiredAuth $ from request 161 | slug = pick @(PathVar "slug" Text) $ from request 162 | maybeArticle <- runDBAction $ Model.favorite currentUserId slug 163 | pure $ maybe notFound404 (ok200 . Wrapped) maybeArticle 164 | 165 | 166 | -------------------------------------------------------------------------------- 167 | 168 | unfavorite :: HasTrait (PathVar "slug" Text) req => Handler' App req LByteString 169 | unfavorite = requiredTokenAuth 170 | $ jsonResponseBody @ArticleResponse 171 | $ handler 172 | where 173 | handler = Kleisli $ \request -> do 174 | let currentUserId = pick @RequiredAuth $ from request 175 | slug = pick @(PathVar "slug" Text) $ from request 176 | maybeArticle <- runDBAction $ Model.unfavorite currentUserId slug 177 | pure $ maybe notFound404 (ok200 . Wrapped) maybeArticle 178 | -------------------------------------------------------------------------------- /webgear-examples/users/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | module Main where 13 | 14 | import Control.Applicative (Alternative (..)) 15 | import Control.Arrow (Kleisli (..)) 16 | import Control.Monad (MonadPlus) 17 | import Control.Monad.Except (MonadError) 18 | import Control.Monad.IO.Class (MonadIO (..)) 19 | import Control.Monad.Reader (MonadReader (..), ReaderT (..)) 20 | import Control.Monad.State.Strict (MonadState) 21 | import Control.Monad.Trans (lift) 22 | import Data.Aeson (FromJSON, ToJSON) 23 | import Data.ByteString.Lazy (ByteString) 24 | import qualified Data.HashMap.Strict as HM 25 | import Data.Hashable (Hashable) 26 | import Data.IORef (IORef, modifyIORef, newIORef, readIORef) 27 | import Data.Maybe (isJust) 28 | import Data.Text (Text) 29 | import Data.Time.Calendar (Day) 30 | import GHC.Generics (Generic) 31 | import Network.HTTP.Types (StdMethod (..)) 32 | import Network.Wai (Application) 33 | import qualified Network.Wai.Handler.Warp as Warp 34 | import WebGear.Middlewares 35 | import WebGear.Trait 36 | import WebGear.Types 37 | 38 | 39 | -------------------------------------------------------------------------------- 40 | -- An example program that uses WebGear to build a simple HTTP API to 41 | -- perform CRUD operations on user records. 42 | -------------------------------------------------------------------------------- 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | -- Model for users 47 | -------------------------------------------------------------------------------- 48 | data User = User 49 | { userId :: UserId 50 | , userName :: Text 51 | , dateOfBirth :: Day 52 | , gender :: Gender 53 | , emailAddress :: Text 54 | } 55 | deriving (Generic, FromJSON, ToJSON) 56 | 57 | newtype UserId = UserId Int 58 | deriving (Eq, FromJSON, ToJSON, Hashable) via Int 59 | 60 | data Gender = Male | Female | OtherGender 61 | deriving (Generic, FromJSON, ToJSON) 62 | 63 | 64 | -------------------------------------------------------------------------------- 65 | -- An in-memory store and associated operations for users 66 | -------------------------------------------------------------------------------- 67 | newtype UserStore = UserStore (IORef (HM.HashMap UserId User)) 68 | 69 | addUser :: MonadIO m => UserStore -> User -> m () 70 | addUser (UserStore ref) user = liftIO $ modifyIORef ref (HM.insert (userId user) user) 71 | 72 | lookupUser :: MonadIO m => UserStore -> UserId -> m (Maybe User) 73 | lookupUser (UserStore ref) uid = liftIO (HM.lookup uid <$> readIORef ref) 74 | 75 | removeUser :: MonadIO m => UserStore -> UserId -> m Bool 76 | removeUser store@(UserStore ref) uid = liftIO $ do 77 | u <- lookupUser store uid 78 | modifyIORef ref (HM.delete uid) 79 | pure $ isJust u 80 | 81 | 82 | -------------------------------------------------------------------------------- 83 | -- Routes of the API 84 | -------------------------------------------------------------------------------- 85 | type IntUserId = PathVar "userId" Int 86 | type Auth = BasicAuth App () Credentials 87 | 88 | authConfig :: BasicAuthConfig App () Credentials 89 | authConfig = BasicAuthConfig 90 | { basicAuthRealm = "Wakanda" 91 | , toBasicAttribute = \creds -> pure $ 92 | if creds == Credentials "panther" "forever" 93 | then Right creds 94 | else Left () 95 | } 96 | 97 | -- The route handlers run in the App monad 98 | newtype App a = App { unApp :: ReaderT UserStore Router a } 99 | deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus 100 | , MonadIO , MonadReader UserStore, MonadError RouteError, MonadState PathInfo) 101 | 102 | instance MonadRouter App where 103 | rejectRoute = App $ lift rejectRoute 104 | errorResponse = App . lift . errorResponse 105 | catchErrorResponse (App (ReaderT action)) handler = App $ ReaderT $ \r -> 106 | catchErrorResponse (action r) (flip runReaderT r . unApp . handler) 107 | 108 | userRoutes :: Handler' App '[] ByteString 109 | userRoutes = [match| /v1/users/userId:Int |] -- non-TH version: path @"/v1/users" . pathVar @"userId" @Int 110 | (publicRoutes <|> protectedRoutes) 111 | 112 | -- | Routes accessible without any authentication 113 | publicRoutes :: HasTrait IntUserId req => Handler' App req ByteString 114 | publicRoutes = getUser 115 | 116 | -- | Routes that require HTTP basic authentication 117 | protectedRoutes :: HasTrait IntUserId req => Handler' App req ByteString 118 | protectedRoutes = basicAuth authConfig 119 | $ putUser <|> deleteUser 120 | 121 | getUser :: HasTrait IntUserId req => Handler' App req ByteString 122 | getUser = method @GET 123 | $ jsonResponseBody @User 124 | $ getUserHandler 125 | 126 | putUser :: HaveTraits [Auth, IntUserId] req => Handler' App req ByteString 127 | putUser = method @PUT 128 | $ requestContentTypeHeader @"application/json" 129 | $ jsonRequestBody @User 130 | $ jsonResponseBody @User 131 | $ putUserHandler 132 | 133 | deleteUser :: HaveTraits [Auth, IntUserId] req => Handler' App req ByteString 134 | deleteUser = method @DELETE deleteUserHandler 135 | 136 | getUserHandler :: ( MonadReader UserStore m 137 | , MonadIO m 138 | , HasTrait IntUserId req 139 | ) 140 | => Handler' m req User 141 | getUserHandler = Kleisli $ \request -> do 142 | let uid = pick @IntUserId $ from request 143 | store <- ask 144 | user <- lookupUser store (UserId uid) 145 | pure $ maybe notFound404 ok200 user 146 | 147 | putUserHandler :: ( MonadReader UserStore m 148 | , MonadIO m 149 | , HaveTraits [Auth, IntUserId, JSONBody User] req 150 | ) 151 | => Handler' m req User 152 | putUserHandler = Kleisli $ \request -> do 153 | let uid = pick @IntUserId $ from request 154 | user = pick @(JSONBody User) $ from request 155 | user' = user { userId = UserId uid } 156 | store <- ask 157 | addUser store user' 158 | logActivity request "updated" 159 | pure $ ok200 user' 160 | 161 | deleteUserHandler :: ( MonadReader UserStore m 162 | , MonadIO m 163 | , HaveTraits [Auth, IntUserId] req 164 | ) 165 | => Handler' m req ByteString 166 | deleteUserHandler = Kleisli $ \request -> do 167 | let uid = pick @IntUserId $ from request 168 | store <- ask 169 | found <- removeUser store (UserId uid) 170 | if found 171 | then logActivity request "deleted" >> pure noContent204 172 | else pure notFound404 173 | 174 | logActivity :: (MonadIO m, HasTrait Auth req) => Linked req Request -> String -> m () 175 | logActivity request msg = do 176 | let name = credentialsUsername $ pick @Auth $ from request 177 | liftIO $ putStrLn $ msg <> ": by " <> show name 178 | 179 | 180 | -------------------------------------------------------------------------------- 181 | -- | The application server 182 | -------------------------------------------------------------------------------- 183 | application :: UserStore -> Application 184 | application store = toApplication $ transform appToRouter userRoutes 185 | where 186 | appToRouter :: App a -> Router a 187 | appToRouter = flip runReaderT store . unApp 188 | 189 | main :: IO () 190 | main = do 191 | store <- newIORef HM.empty 192 | Warp.run 3000 (application $ UserStore store) 193 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Auth/JWT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Copyright : (c) Raghu Kaippully, 2020-2021 5 | -- License : MPL-2.0 6 | -- Maintainer : rkaippully@gmail.com 7 | -- 8 | -- JWT authentication support. 9 | -- 10 | module WebGear.Middlewares.Auth.JWT 11 | ( JWTAuth' 12 | , JWTAuth 13 | , JWTAuthConfig (..) 14 | , Realm (..) 15 | , JWTAuthError (..) 16 | , jwtAuth 17 | , optionalJWTAuth 18 | , jwtAuth' 19 | , optionalJWTAuth' 20 | , mkJWT 21 | ) where 22 | 23 | import Control.Arrow (Kleisli (..)) 24 | import Control.Monad ((>=>)) 25 | import Control.Monad.Except (MonadError (throwError), lift, runExceptT, withExceptT) 26 | import Control.Monad.IO.Class (MonadIO (..)) 27 | import Control.Monad.Time (MonadTime) 28 | import qualified Crypto.JWT as JWT 29 | import Data.Aeson (Object, Result (..), Value (..), fromJSON) 30 | import Data.ByteString.Lazy (fromStrict) 31 | import Data.Proxy (Proxy (..)) 32 | import Data.String (fromString) 33 | import Data.Text.Lazy () 34 | import Data.Void (Void, absurd) 35 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 36 | import WebGear.Middlewares.Auth.Util (AuthToken (..), AuthorizationHeader, Realm (..), 37 | authorizationHeader, respondUnauthorized) 38 | import WebGear.Modifiers (Existence (..)) 39 | import WebGear.Trait (HasTrait (..), Linked, Trait (..), pick, transcribe) 40 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response, forbidden403) 41 | 42 | 43 | -- | Trait for JWT authentication with a bearer token: 44 | -- https://tools.ietf.org/html/rfc6750 45 | -- 46 | -- This trait supports a custom scheme instead of the standard 47 | -- "Bearer" scheme. 48 | data JWTAuth' (x :: Existence) (scheme :: Symbol) m e a = JWTAuth' 49 | { jwtValidationSettings :: JWT.JWTValidationSettings 50 | , jwkSet :: JWT.JWKSet 51 | , toJWTAttribute :: JWT.ClaimsSet -> m (Either e a) 52 | } 53 | 54 | type JWTAuth = JWTAuth' Required "Bearer" 55 | 56 | -- | Configuration settings for JWT authentication 57 | data JWTAuthConfig m e a = JWTAuthConfig 58 | { jwtAuthRealm :: Realm 59 | , jwtValidationSettings :: JWT.JWTValidationSettings 60 | , jwkSet :: JWT.JWKSet 61 | , toJWTAttribute :: JWT.ClaimsSet -> m (Either e a) 62 | } 63 | 64 | data JWTAuthError e = JWTAuthHeaderMissing 65 | | JWTAuthSchemeMismatch 66 | | JWTAuthTokenBadFormat JWT.JWTError 67 | | JWTAuthAttributeError e 68 | deriving (Eq, Show) 69 | 70 | parseJWT :: AuthToken scheme -> Either JWT.JWTError JWT.SignedJWT 71 | parseJWT AuthToken{..} = JWT.decodeCompact $ fromStrict authToken 72 | 73 | instance (HasTrait (AuthorizationHeader scheme) ts, MonadIO m, MonadTime m) => Trait (JWTAuth' Required scheme m e a) ts Request m where 74 | type Attribute (JWTAuth' Required scheme m e a) Request = a 75 | type Absence (JWTAuth' Required scheme m e a) Request = JWTAuthError e 76 | 77 | tryLink :: JWTAuth' Required scheme m e a 78 | -> Linked ts Request 79 | -> m (Either (JWTAuthError e) a) 80 | tryLink JWTAuth'{..} r = 81 | case pick @(AuthorizationHeader scheme) (from r) of 82 | Nothing -> pure $ Left JWTAuthHeaderMissing 83 | Just (Left _) -> pure $ Left JWTAuthSchemeMismatch 84 | Just (Right token) -> either (pure . Left . JWTAuthTokenBadFormat) validateJWT (parseJWT token) 85 | where 86 | validateJWT :: JWT.SignedJWT -> m (Either (JWTAuthError e) a) 87 | validateJWT jwt = runExceptT $ do 88 | claims <- withExceptT JWTAuthTokenBadFormat $ JWT.verifyClaims jwtValidationSettings jwkSet jwt 89 | lift (toJWTAttribute claims) >>= either (throwError . JWTAuthAttributeError) pure 90 | 91 | instance (HasTrait (AuthorizationHeader scheme) ts, MonadIO m, MonadTime m) => Trait (JWTAuth' Optional scheme m e a) ts Request m where 92 | type Attribute (JWTAuth' Optional scheme m e a) Request = Either (JWTAuthError e) a 93 | type Absence (JWTAuth' Optional scheme m e a) Request = Void 94 | 95 | tryLink :: JWTAuth' Optional scheme m e a 96 | -> Linked ts Request 97 | -> m (Either Void (Either (JWTAuthError e) a)) 98 | tryLink JWTAuth'{..} r = Right <$> tryLink (JWTAuth'{..} :: JWTAuth' Required scheme m e a) r 99 | 100 | 101 | -- | Middleware to add JWT authentication protection for a 102 | -- handler. Expects the JWT to be available via a standard bearer 103 | -- authorization header in the format: 104 | -- 105 | -- > Authorization: Bearer 106 | -- 107 | -- Example usage: 108 | -- 109 | -- > jwtAuth cfg handler 110 | -- 111 | -- This middleware returns a 401 response if the authorization header 112 | -- is missing or formatted incorrectly. It returns a 403 response if 113 | -- the JWT is invalid. 114 | jwtAuth :: forall m req e t a. (MonadRouter m, MonadIO m, MonadTime m) 115 | => JWTAuthConfig m e t 116 | -> RequestMiddleware' m req (JWTAuth m e t : req) a 117 | jwtAuth = jwtAuth' @"Bearer" 118 | 119 | -- | Middleware to add optional JWT authentication protection for a 120 | -- handler. Expects the JWT to be available via a standard bearer 121 | -- authorization header in the format: 122 | -- 123 | -- > Authorization: Bearer 124 | -- 125 | -- Example usage: 126 | -- 127 | -- > optionalJWTAuth cfg handler 128 | -- 129 | -- This middleware will not fail if authorization credentials are 130 | -- invalid or missing in the request. Instead the trait attribute is 131 | -- of type Either 'JWTAuthError' 'JWT.ClaimsSet' so that the handler 132 | -- can process the authentication error appropriately. 133 | optionalJWTAuth :: forall m req e t a. (MonadRouter m, MonadIO m, MonadTime m) 134 | => JWTAuthConfig m e t 135 | -> RequestMiddleware' m req (JWTAuth' Optional "Bearer" m e t : req) a 136 | optionalJWTAuth = optionalJWTAuth' @"Bearer" 137 | 138 | -- | Middleware to add JWT authentication protection for a 139 | -- handler. Expects the JWT to be available via an authorization 140 | -- header in the format: 141 | -- 142 | -- > Authorization: 143 | -- 144 | -- Example usage: 145 | -- 146 | -- > jwtAuth' @"" cfg handler 147 | -- 148 | -- This middleware returns a 401 response if the authorization header 149 | -- is missing or formatted incorrectly. It returns a 403 response if 150 | -- the JWT is invalid. 151 | jwtAuth' :: forall scheme m req e t a. (MonadRouter m, MonadIO m, MonadTime m, KnownSymbol scheme) 152 | => JWTAuthConfig m e t 153 | -> RequestMiddleware' m req (JWTAuth' Required scheme m e t : req) a 154 | jwtAuth' JWTAuthConfig{..} handler = authorizationHeader @scheme $ Kleisli $ 155 | transcribe JWTAuth'{..} >=> either mkError (runKleisli handler) 156 | where 157 | mkError :: JWTAuthError e -> m (Response a) 158 | mkError (JWTAuthTokenBadFormat e) = errorResponse $ forbidden403 $ fromString $ show e 159 | mkError _ = respondUnauthorized schemeName jwtAuthRealm 160 | 161 | schemeName = fromString $ symbolVal $ Proxy @scheme 162 | 163 | -- | Middleware to add JWT authentication protection for a 164 | -- handler. Expects the JWT to be available via an authorization 165 | -- header in the format: 166 | -- 167 | -- > Authorization: 168 | -- 169 | -- Example usage: 170 | -- 171 | -- > optionalJWTAuth' @"" cfg handler 172 | -- 173 | -- This middleware will not fail if authorization credentials are 174 | -- invalid or missing in the request. Instead the trait attribute is 175 | -- of type Either 'JWTAuthError' 'JWT.ClaimsSet' so that the handler 176 | -- can process the authentication error appropriately. 177 | optionalJWTAuth' :: forall scheme m req e t a. (MonadRouter m, MonadIO m, MonadTime m, KnownSymbol scheme) 178 | => JWTAuthConfig m e t 179 | -> RequestMiddleware' m req (JWTAuth' Optional scheme m e t : req) a 180 | optionalJWTAuth' JWTAuthConfig{..} handler = authorizationHeader @scheme $ Kleisli $ 181 | transcribe JWTAuth'{..} >=> either absurd (runKleisli handler) 182 | 183 | 184 | -- | Generate a signed JWT from a JWK and claims 185 | mkJWT :: JWT.MonadRandom m 186 | => JWT.JWK 187 | -> Object -- ^ claim set as a JSON object 188 | -> m (Either JWT.JWTError JWT.SignedJWT) 189 | mkJWT jwk claims = runExceptT $ do 190 | alg <- JWT.bestJWSAlg jwk 191 | let hdr = JWT.newJWSHeader ((), alg) 192 | case fromJSON (Object claims) of 193 | Error s -> throwError $ JWT.JWTClaimsSetDecodeError s 194 | Success claims' -> JWT.signClaims jwk hdr claims' 195 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Params.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares for handling query parameters 7 | -- 8 | module WebGear.Middlewares.Params 9 | ( -- * Traits 10 | QueryParam 11 | , QueryParam' (..) 12 | , ParamNotFound (..) 13 | , ParamParseError (..) 14 | 15 | -- * Middlewares 16 | , queryParam 17 | , optionalQueryParam 18 | , lenientQueryParam 19 | , optionalLenientQueryParam 20 | ) where 21 | 22 | import Control.Arrow (Kleisli (..)) 23 | import Control.Monad ((>=>)) 24 | import qualified Data.ByteString.Lazy as LBS 25 | import Data.List (find) 26 | import Data.Proxy (Proxy (..)) 27 | import Data.String (fromString) 28 | import Data.Text (Text) 29 | import Data.Void (Void, absurd) 30 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 31 | import Network.HTTP.Types (queryToQueryText) 32 | import Text.Printf (printf) 33 | import Web.HttpApiData (FromHttpApiData (..)) 34 | import WebGear.Modifiers (Existence (..), ParseStyle (..)) 35 | import WebGear.Trait (Linked, Trait (..), probe, unlink) 36 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), badRequest400, 37 | queryString) 38 | 39 | 40 | -- | Capture a query parameter with a specified @name@ and convert it 41 | -- to a value of type @val@ via 'FromHttpApiData'. 42 | type QueryParam (name :: Symbol) val = QueryParam' Required Strict name val 43 | 44 | -- | Capture a query parameter with a specified @name@ and convert it 45 | -- to a value of type @val@ via 'FromHttpApiData'. The type parameter 46 | -- @e@ denotes whether the query parameter is required to be 47 | -- present. The parse style parameter @p@ determines whether the 48 | -- conversion is applied strictly or leniently. 49 | data QueryParam' (e :: Existence) (p :: ParseStyle) (name :: Symbol) val = QueryParam' 50 | 51 | -- | Indicates a missing query parameter 52 | data ParamNotFound = ParamNotFound 53 | deriving stock (Read, Show, Eq) 54 | 55 | -- | Error in converting a query parameter 56 | newtype ParamParseError = ParamParseError Text 57 | deriving stock (Read, Show, Eq) 58 | 59 | deriveRequestParam :: (KnownSymbol name, FromHttpApiData val) 60 | => Proxy name -> Linked ts Request -> (Maybe (Either Text val) -> r) -> r 61 | deriveRequestParam proxy req cont = 62 | let name = fromString $ symbolVal proxy 63 | params = queryToQueryText $ queryString $ unlink req 64 | in cont $ parseQueryParam <$> (find ((== name) . fst) params >>= snd) 65 | 66 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Strict name val) ts Request m where 67 | type Attribute (QueryParam' Required Strict name val) Request = val 68 | type Absence (QueryParam' Required Strict name val) Request = Either ParamNotFound ParamParseError 69 | 70 | tryLink :: QueryParam' Required Strict name val 71 | -> Linked ts Request 72 | -> m (Either (Either ParamNotFound ParamParseError) val) 73 | tryLink _ r = pure $ deriveRequestParam (Proxy @name) r $ \case 74 | Nothing -> Left $ Left ParamNotFound 75 | Just (Left e) -> Left $ Right $ ParamParseError e 76 | Just (Right x) -> Right x 77 | 78 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Strict name val) ts Request m where 79 | type Attribute (QueryParam' Optional Strict name val) Request = Maybe val 80 | type Absence (QueryParam' Optional Strict name val) Request = ParamParseError 81 | 82 | tryLink :: QueryParam' Optional Strict name val 83 | -> Linked ts Request 84 | -> m (Either ParamParseError (Maybe val)) 85 | tryLink _ r = pure $ deriveRequestParam (Proxy @name) r $ \case 86 | Nothing -> Right Nothing 87 | Just (Left e) -> Left $ ParamParseError e 88 | Just (Right x) -> Right $ Just x 89 | 90 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Required Lenient name val) ts Request m where 91 | type Attribute (QueryParam' Required Lenient name val) Request = Either Text val 92 | type Absence (QueryParam' Required Lenient name val) Request = ParamNotFound 93 | 94 | tryLink :: QueryParam' Required Lenient name val 95 | -> Linked ts Request 96 | -> m (Either ParamNotFound (Either Text val)) 97 | tryLink _ r = pure $ deriveRequestParam (Proxy @name) r $ \case 98 | Nothing -> Left ParamNotFound 99 | Just (Left e) -> Right $ Left e 100 | Just (Right x) -> Right $ Right x 101 | 102 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (QueryParam' Optional Lenient name val) ts Request m where 103 | type Attribute (QueryParam' Optional Lenient name val) Request = Maybe (Either Text val) 104 | type Absence (QueryParam' Optional Lenient name val) Request = Void 105 | 106 | tryLink :: QueryParam' Optional Lenient name val 107 | -> Linked ts Request 108 | -> m (Either Void (Maybe (Either Text val))) 109 | tryLink _ r = pure $ deriveRequestParam (Proxy @name) r $ \case 110 | Nothing -> Right Nothing 111 | Just (Left e) -> Right $ Just $ Left e 112 | Just (Right x) -> Right $ Just $ Right x 113 | 114 | 115 | -- | A middleware to extract a query parameter and convert it to a 116 | -- value of type @val@ using 'FromHttpApiData'. 117 | -- 118 | -- Example usage: 119 | -- 120 | -- > queryParam @"limit" @Int handler 121 | -- 122 | -- The associated trait attribute has type @val@. This middleware will 123 | -- respond with a 400 Bad Request response if the query parameter is 124 | -- not found or could not be parsed. 125 | queryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) 126 | => RequestMiddleware' m req (QueryParam name val:req) a 127 | queryParam handler = Kleisli $ 128 | probe QueryParam' >=> either (errorResponse . mkError) (runKleisli handler) 129 | where 130 | paramName :: String 131 | paramName = symbolVal $ Proxy @name 132 | 133 | mkError :: Either ParamNotFound ParamParseError -> Response LBS.ByteString 134 | mkError err = badRequest400 $ fromString $ 135 | case err of 136 | Left ParamNotFound -> printf "Could not find query parameter %s" paramName 137 | Right (ParamParseError _) -> printf "Invalid value for query parameter %s" paramName 138 | 139 | -- | A middleware to extract an optional query parameter and convert 140 | -- it to a value of type @val@ using 'FromHttpApiData'. 141 | -- 142 | -- Example usage: 143 | -- 144 | -- > optionalQueryParam @"limit" @Int handler 145 | -- 146 | -- The associated trait attribute has type @Maybe val@; a @Nothing@ 147 | -- value indicates a missing param. A 400 Bad Request response is 148 | -- returned if the query parameter could not be parsed. 149 | optionalQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) 150 | => RequestMiddleware' m req (QueryParam' Optional Strict name val:req) a 151 | optionalQueryParam handler = Kleisli $ 152 | probe QueryParam' >=> either (errorResponse . mkError) (runKleisli handler) 153 | where 154 | paramName :: String 155 | paramName = symbolVal $ Proxy @name 156 | 157 | mkError :: ParamParseError -> Response LBS.ByteString 158 | mkError _ = badRequest400 $ fromString $ printf "Invalid value for query parameter %s" paramName 159 | 160 | -- | A middleware to extract a query parameter and convert it to a 161 | -- value of type @val@ using 'FromHttpApiData'. 162 | -- 163 | -- Example usage: 164 | -- 165 | -- > lenientQueryParam @"limit" @Int handler 166 | -- 167 | -- The associated trait attribute has type @Either Text val@. A 400 168 | -- Bad Request reponse is returned if the query parameter is 169 | -- missing. The parsing is done leniently; the trait attribute is set 170 | -- to @Left Text@ in case of parse errors or @Right val@ on success. 171 | lenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) 172 | => RequestMiddleware' m req (QueryParam' Required Lenient name val:req) a 173 | lenientQueryParam handler = Kleisli $ 174 | probe QueryParam' >=> either (errorResponse . mkError) (runKleisli handler) 175 | where 176 | paramName :: String 177 | paramName = symbolVal $ Proxy @name 178 | 179 | mkError :: ParamNotFound -> Response LBS.ByteString 180 | mkError ParamNotFound = badRequest400 $ fromString $ printf "Could not find query parameter %s" paramName 181 | 182 | -- | A middleware to extract an optional query parameter and convert it 183 | -- to a value of type @val@ using 'FromHttpApiData'. 184 | -- 185 | -- Example usage: 186 | -- 187 | -- > optionalLenientHeader @"Content-Length" @Integer handler 188 | -- 189 | -- The associated trait attribute has type @Maybe (Either Text 190 | -- val)@. This middleware never fails. 191 | optionalLenientQueryParam :: forall name val m req a. (KnownSymbol name, FromHttpApiData val, MonadRouter m) 192 | => RequestMiddleware' m req (QueryParam' Optional Lenient name val:req) a 193 | optionalLenientQueryParam handler = Kleisli $ 194 | probe QueryParam' >=> either absurd (runKleisli handler) 195 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | {-# OPTIONS_HADDOCK ignore-exports #-} 3 | -- | 4 | -- Copyright : (c) Raghu Kaippully, 2020 5 | -- License : MPL-2.0 6 | -- Maintainer : rkaippully@gmail.com 7 | -- 8 | -- WebGear helps to build composable, type-safe HTTP API servers. 9 | -- 10 | -- The documentation below gives an overview of WebGear. Example 11 | -- programs built using WebGear are available at 12 | -- https://github.com/rkaippully/webgear/tree/master/webgear-examples. 13 | -- 14 | module WebGear 15 | ( -- * Serving HTTP APIs 16 | -- $serving 17 | 18 | -- * Traits and Linking 19 | -- $traits 20 | 21 | -- * Handlers 22 | -- $handlers 23 | 24 | -- * Middlewares 25 | -- $middlewares 26 | 27 | -- * Handlers 28 | -- $handlers 29 | 30 | -- * Routing 31 | -- $routing 32 | 33 | -- * Running the Server 34 | -- $running 35 | 36 | -- * Servers with other monads 37 | -- $otherMonads 38 | 39 | module Control.Applicative 40 | , module Control.Arrow 41 | , module Data.ByteString.Lazy 42 | , module Data.ByteString.Conversion.To 43 | , module Data.Proxy 44 | , module Data.Text 45 | , module Web.HttpApiData 46 | , module WebGear.Middlewares 47 | , module WebGear.Handlers.Static 48 | , module WebGear.Trait 49 | , module WebGear.Types 50 | ) where 51 | 52 | import Control.Applicative (Alternative ((<|>))) 53 | import Control.Arrow (Kleisli (..)) 54 | import Data.ByteString.Conversion.To 55 | import Data.ByteString.Lazy (ByteString) 56 | import Data.Proxy (Proxy (..)) 57 | import Data.Text 58 | import Web.HttpApiData (FromHttpApiData (..)) 59 | 60 | import qualified Network.Wai as Wai 61 | 62 | import WebGear.Handlers.Static 63 | import WebGear.Middlewares 64 | import WebGear.Trait 65 | import WebGear.Types 66 | 67 | 68 | -- 69 | -- $serving 70 | -- 71 | -- An HTTP API server handler can be thought of as a function that 72 | -- takes a request as input and produces a response as output in a 73 | -- monadic context. 74 | -- 75 | -- > handler :: Monad m => Request -> m Response 76 | -- 77 | -- For reasons that will be explained later, WebGear uses the 'Router' 78 | -- monad for running handlers. Thus the above type signature changes 79 | -- to: 80 | -- 81 | -- > handler :: Request -> Router Response 82 | -- 83 | -- Most APIs will require extracting some information from the 84 | -- request, processing it and then producing a response. For example, 85 | -- the server might require access to some HTTP header values, query 86 | -- parameters, or the request body. WebGear allows to access such 87 | -- information using traits. 88 | -- 89 | -- 90 | -- $traits 91 | -- 92 | -- A trait is an attribute associated with a value. For example, a 93 | -- @Request@ might have a header that we are interested in, which is 94 | -- represented by the 'Header' trait. All traits have instances of the 95 | -- 'Trait' typeclass. The 'toAttribute' function helps to check 96 | -- presence of the trait. It also has two associated types - 97 | -- 'Attribute' and 'Absence' - to represent the result of the 98 | -- extraction. 99 | -- 100 | -- For example, the 'Header' trait has an instance of the 'Trait' 101 | -- typeclass. The 'toAttribute' function evaluates to a 'Found' or 102 | -- 'NotFound' value depending on whether we can successfully retrieve 103 | -- the header value. 104 | -- 105 | -- WebGear provides type-safety by linking traits to the request at 106 | -- type level. The 'Linked' data type associates a 'Request' with a 107 | -- list of traits. This linking guarantees that the Request has the 108 | -- specified trait. 109 | -- 110 | -- These functions work with traits and linked values: 111 | -- 112 | -- * 'link': Establish a link between a value and an empty list of 113 | -- traits. This always succeeds. 114 | -- 115 | -- * 'unlink': Convert a linked value to a regular value without any 116 | -- type-level traits. 117 | -- 118 | -- * 'probe': Attempts to establish a link between a linked value 119 | -- with an additional trait using 'toAttribute'. 120 | -- 121 | -- * 'remove': Removes a trait from the list of linked traits. 122 | -- 123 | -- * 'get': Extract an 'Attribute' associated with a trait from a 124 | -- linked value. 125 | -- 126 | -- For example, we make use of the @'Method' \@GET@ trait to ensure 127 | -- that our handler is called only for GET requests. We can link a 128 | -- request value with this trait using: 129 | -- 130 | -- @ 131 | -- linkedRequest :: Monad m => 'Request' -> 'Router' (Either 'MethodMismatch' ('Linked' '['Method' GET] 'Request')) 132 | -- linkedRequest = 'probe' @('Method' GET) . 'link' 133 | -- @ 134 | -- 135 | -- Let us modify the type signature of our handler to use linked 136 | -- values instead of regular values: 137 | -- 138 | -- > handler :: Linked req Request -> Router Response 139 | -- 140 | -- Here, @req@ is a type-level list of traits associated with the 141 | -- @Request@ that this handler requires. This ensures that this 142 | -- handler can only be called with a request possessing certain 143 | -- traits thus providing type-safety to our handlers. 144 | -- 145 | -- 146 | -- $handlers 147 | -- 148 | -- Handlers in WebGear are defined with a type very similar to the 149 | -- above. 150 | -- 151 | -- @ 152 | -- type 'Handler'' m req a = 'Kleisli' m ('Linked' req 'Request') ('Response' a) 153 | -- 154 | -- type 'Handler' req a = 'Handler'' 'Router' req a 155 | -- @ 156 | -- 157 | -- It is a 'Kleisli' arrow as described in the above section with 158 | -- type-level trait lists. However, the response is parameterized by 159 | -- the type variable @a@, which represents the type of the response 160 | -- body. 161 | -- 162 | -- 'Handler'' can work with any monad while 'Handler' works with 163 | -- 'Router'. 164 | -- 165 | -- A handler can extract some trait attribute of a request with the 166 | -- 'get' function. 167 | -- 168 | -- 169 | -- $middlewares 170 | -- 171 | -- A middleware is a higher-order function that takes a handler as 172 | -- input and produces another handler with potentially different 173 | -- request and response types. Thus middlewares can augment the 174 | -- functionality of another handler. 175 | -- 176 | -- For example, here is the definition of the 'method' middleware: 177 | -- 178 | -- @ 179 | -- method :: ('IsStdMethod' t, 'MonadRouter' m) => 'Handler'' m ('Method' t:req) a -> 'Handler'' m req a 180 | -- method handler = 'Kleisli' $ 'probe' \@('Method' t) >=> 'either' ('const' 'rejectRoute') ('runKleisli' handler) 181 | -- @ 182 | -- 183 | -- The @probe \@(Method t)@ function is used to ensure that the 184 | -- request has method @t@ before invoking the @handler@. In case of a 185 | -- mismatch, this route is rejected by calling 'rejectRoute'. 186 | -- 187 | -- Many middlewares can be composed to form complex request handling 188 | -- logic. For example: 189 | -- 190 | -- @ 191 | -- putUser = 'method' \@PUT 192 | -- $ 'requestContentTypeHeader' \@"application/json" 193 | -- $ 'jsonRequestBody' \@User 194 | -- $ 'jsonResponseBody' \@User 195 | -- $ putUserHandler 196 | -- @ 197 | -- 198 | -- 199 | -- $handlers 200 | -- 201 | -- WebGear provides some standard handlers. 202 | -- 203 | -- 204 | -- $routing 205 | -- 206 | -- A typical server will have many routes and we would like to pick 207 | -- one based on the URL path, HTTP method etc. We need a couple of 208 | -- things to achieve this. 209 | -- 210 | -- First, we need a way to indicate that a handler cannot handle a 211 | -- request, possibly because the path or method did not match with 212 | -- what was expected. This is achieved by the 'rejectRoute' function: 213 | -- 214 | -- @ 215 | -- class (Alternative m, MonadPlus m) => 'MonadRouter' m where 216 | -- 'rejectRoute' :: m a 217 | -- 'errorResponse' :: 'Response' 'ByteString' -> m a 218 | -- 'catchErrorResponse' :: m a -> ('Response' 'ByteString' -> m a) -> m a 219 | -- @ 220 | -- 221 | -- The 'errorResponse' can be used in cases where we find a matching 222 | -- route but the request handling is aborted for some reason. For 223 | -- example, if a route requires the request Content-type header to 224 | -- have a particular value but the actual request had a different 225 | -- Content-type, 'errorResponse' can be used to abort and return an 226 | -- error response. 227 | -- 228 | -- Second, we need a mechanism to try an alternate route when one 229 | -- route is rejected. Since 'MonadRouter' is an 'Alternative', we can 230 | -- use '<|>' to combine many routes. When a request arrives, a match 231 | -- will be attempted against each route sequentially and the first 232 | -- matching route handler will process the request. Here is an 233 | -- example: 234 | -- 235 | -- @ 236 | -- allRoutes :: 'Handler' '[] 'ByteString' 237 | -- allRoutes = ['match'| /v1\/users\/userId:Int |] -- non-TH version: 'path' \@"/v1/users" . 'pathVar' \@"userId" \@Int 238 | -- $ getUser \<|\> putUser \<|\> deleteUser 239 | -- 240 | -- type IntUserId = 'PathVar' "userId" Int 241 | -- 242 | -- getUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' 243 | -- getUser = 'method' \@GET getUserHandler 244 | -- 245 | -- putUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' 246 | -- putUser = 'method' \@PUT 247 | -- $ 'requestContentTypeHeader' \@"application/json" 248 | -- $ 'jsonRequestBody' \@User 249 | -- $ putUserHandler 250 | -- 251 | -- deleteUser :: 'Has' IntUserId req => 'Handler' req 'ByteString' 252 | -- deleteUser = 'method' \@DELETE deleteUserHandler 253 | -- @ 254 | -- 255 | -- 256 | -- $running 257 | -- 258 | -- Routable handlers can be converted to a Wai 'Wai.Application' using 259 | -- 'toApplication': 260 | -- 261 | -- @ 262 | -- toApplication :: 'ToByteString' a => 'Handler' '[] a -> 'Wai.Application' 263 | -- @ 264 | -- 265 | -- This Wai application can then be run as a Warp web server. 266 | -- 267 | -- @ 268 | -- main :: IO () 269 | -- main = Warp.run 3000 $ 'toApplication' allRoutes 270 | -- @ 271 | -- 272 | -- 273 | -- $otherMonads 274 | -- 275 | -- It may not be practical to use 'Router' monad for your handlers. In 276 | -- most cases, you would need your own monad transformer stack or 277 | -- algebraic effect runners. WebGear supports that easily. 278 | -- 279 | -- Let us say, the @putUserHandler@ from the above example runs on 280 | -- some monad other than 'Router'. You can still use it as a handler thus: 281 | -- 282 | -- @ 283 | -- putUser = 'method' \@PUT 284 | -- $ 'requestContentTypeHeader' \@"application/json" 285 | -- $ 'jsonRequestBody' \@User 286 | -- $ 'jsonResponseBody' \@User 287 | -- $ 'transform' customMonadToRouter putUserHandler 288 | -- 289 | -- putUserHandler :: 'Handler'' MyCustomMonad req User 290 | -- putUserHandler = .... 291 | -- 292 | -- customMonadToRouter :: MyCustomMonad a -> Router a 293 | -- customMonadToRouter = ... 294 | -- @ 295 | -- 296 | -- As long as you have a way of transforming values in your custom 297 | -- monad to a 'Router' monadic value, you can use 'transform' to 298 | -- convert the handlers in that custom monad to handlers running in 299 | -- 'Router' monad. 300 | -- 301 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Path.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares related to route paths. 7 | module WebGear.Middlewares.Path 8 | ( Path (..) 9 | , PathVar (..) 10 | , PathVarError (..) 11 | , PathEnd (..) 12 | , path 13 | , pathVar 14 | , pathEnd 15 | , match 16 | , route 17 | ) where 18 | 19 | import Control.Arrow (Kleisli (..)) 20 | import Control.Monad ((>=>)) 21 | import Control.Monad.State.Strict (MonadState (..)) 22 | import Data.Foldable (toList) 23 | import Data.Function ((&)) 24 | import qualified Data.List as List 25 | import Data.List.NonEmpty (NonEmpty (..), filter) 26 | import Data.Proxy (Proxy (..)) 27 | import Data.Text (Text, pack) 28 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 29 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 30 | import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName) 31 | import Prelude hiding (drop, filter, take) 32 | import Web.HttpApiData (FromHttpApiData (..)) 33 | import WebGear.Middlewares.Method (method) 34 | import WebGear.Trait (Linked, Trait (..), probe) 35 | import WebGear.Types (MonadRouter (..), PathInfo (..), Request, RequestMiddleware') 36 | import WebGear.Util (splitOn) 37 | 38 | 39 | -- | A path component which is literally matched against the request 40 | -- but discarded after that. 41 | data Path (s :: Symbol) = Path 42 | 43 | instance (KnownSymbol s, MonadState PathInfo m) => Trait (Path s) ts Request m where 44 | type Attribute (Path s) Request = () 45 | type Absence (Path s) Request = () 46 | 47 | tryLink :: Path s 48 | -> Linked ts Request 49 | -> m (Either () ()) 50 | tryLink _ _ = do 51 | PathInfo actualPath <- get 52 | case List.stripPrefix expectedPath actualPath of 53 | Nothing -> pure $ Left () 54 | Just rest -> do 55 | put $ PathInfo rest 56 | pure $ Right () 57 | where 58 | expectedPath = Proxy @s 59 | & symbolVal 60 | & splitOn '/' 61 | & filter (/= "") 62 | & map pack 63 | 64 | 65 | -- | A path variable that is extracted and converted to a value of 66 | -- type @val@. The @tag@ is usually a type-level symbol (string) to 67 | -- uniquely identify this variable. 68 | data PathVar tag val = PathVar 69 | 70 | -- | Failure to extract a 'PathVar' 71 | data PathVarError = PathVarNotFound | PathVarParseError Text 72 | deriving (Eq, Show, Read) 73 | 74 | instance (FromHttpApiData val, MonadState PathInfo m) => Trait (PathVar tag val) ts Request m where 75 | type Attribute (PathVar tag val) Request = val 76 | type Absence (PathVar tag val) Request = PathVarError 77 | 78 | tryLink :: PathVar tag val 79 | -> Linked ts Request 80 | -> m (Either PathVarError val) 81 | tryLink _ _ = do 82 | PathInfo actualPath <- get 83 | case actualPath of 84 | [] -> pure $ Left PathVarNotFound 85 | (x:xs) -> case parseUrlPiece @val x of 86 | Left e -> pure $ Left $ PathVarParseError e 87 | Right v -> do 88 | put $ PathInfo xs 89 | pure $ Right v 90 | 91 | -- | Trait to indicate that no more path components are present in the request 92 | data PathEnd = PathEnd 93 | 94 | instance MonadState PathInfo m => Trait PathEnd ts Request m where 95 | type Attribute PathEnd Request = () 96 | type Absence PathEnd Request = () 97 | 98 | tryLink :: PathEnd 99 | -> Linked ts Request 100 | -> m (Either () ()) 101 | tryLink _ _ = do 102 | PathInfo actualPath <- get 103 | pure $ if null actualPath 104 | then Right () 105 | else Left () 106 | 107 | 108 | -- | A middleware that literally matches path @s@. 109 | -- 110 | -- The symbol @s@ could contain one or more parts separated by a 111 | -- forward slash character. The route will be rejected if there is no 112 | -- match. 113 | -- 114 | -- For example, the following code could be used to match the URL path 115 | -- \"a\/b\/c\" and then invoke @handler@: 116 | -- 117 | -- > path @"a/b/c" handler 118 | -- 119 | path :: forall s ts m a. (KnownSymbol s, MonadRouter m) 120 | => RequestMiddleware' m ts (Path s:ts) a 121 | path handler = Kleisli $ 122 | probe Path >=> either (const rejectRoute) (runKleisli handler) 123 | 124 | -- | A middleware that captures a path variable from a single path 125 | -- component. 126 | -- 127 | -- The value captured is converted to a value of type @val@ via 128 | -- 'FromHttpApiData'. The route will be rejected if the value is not 129 | -- found or cannot be converted. 130 | -- 131 | -- For example, the following code could be used to read a path 132 | -- component as 'Int' tagged with the symbol \"objId\", and then 133 | -- invoke @handler@: 134 | -- 135 | -- > pathVar @"objId" @Int handler 136 | -- 137 | pathVar :: forall tag val ts m a. (FromHttpApiData val, MonadRouter m) 138 | => RequestMiddleware' m ts (PathVar tag val:ts) a 139 | pathVar handler = Kleisli $ 140 | probe PathVar >=> either (const rejectRoute) (runKleisli handler) 141 | 142 | -- | A middleware that verifies that end of path is reached. 143 | pathEnd :: MonadRouter m => RequestMiddleware' m ts (PathEnd:ts) a 144 | pathEnd handler = Kleisli $ 145 | probe PathEnd >=> either (const rejectRoute) (runKleisli handler) 146 | 147 | -- | Produces middleware(s) to match an optional HTTP method and some 148 | -- path components. 149 | -- 150 | -- This middleware matches a prefix of path components, the remaining 151 | -- components can be matched by subsequent uses of 'match'. 152 | -- 153 | -- This quasiquoter can be used in several ways: 154 | -- 155 | -- +---------------------------------------+---------------------------------------------------------------------------------------+ 156 | -- | QuasiQuoter | Equivalent Middleware | 157 | -- +=======================================+=======================================================================================+ 158 | -- | @[match| \/a\/b\/c |]@ | @'path' \@\"\/a\/b\/c\"@ | 159 | -- +---------------------------------------+---------------------------------------------------------------------------------------+ 160 | -- | @[match| \/a\/b\/objId:Int\/d |]@ | @'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@ | 161 | -- +---------------------------------------+---------------------------------------------------------------------------------------+ 162 | -- | @[match| GET \/a\/b\/c |]@ | @'method' \@GET . 'path' \@\"\/a\/b\/c\"@ | 163 | -- +---------------------------------------+---------------------------------------------------------------------------------------+ 164 | -- | @[match| GET \/a\/b\/objId:Int\/d |]@ | @'method' \@GET . 'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\"@ | 165 | -- +---------------------------------------+---------------------------------------------------------------------------------------+ 166 | -- 167 | match :: QuasiQuoter 168 | match = QuasiQuoter 169 | { quoteExp = toMatchExp 170 | , quotePat = const $ fail "match cannot be used in a pattern" 171 | , quoteType = const $ fail "match cannot be used in a type" 172 | , quoteDec = const $ fail "match cannot be used in a declaration" 173 | } 174 | 175 | -- | Produces middleware(s) to match an optional HTTP method and the 176 | -- entire request path. 177 | -- 178 | -- This middleware is intended to be used in cases where the entire 179 | -- path needs to be matched. Use 'match' middleware to match only an 180 | -- initial portion of the path. 181 | -- 182 | -- This quasiquoter can be used in several ways: 183 | -- 184 | -- +---------------------------------------+---------------------------------------------------------------------------------------------------+ 185 | -- | QuasiQuoter | Equivalent Middleware | 186 | -- +=======================================+===================================================================================================+ 187 | -- | @[route| \/a\/b\/c |]@ | @'path' \@\"\/a\/b\/c\" . 'pathEnd'@ | 188 | -- +---------------------------------------+---------------------------------------------------------------------------------------------------+ 189 | -- | @[route| \/a\/b\/objId:Int\/d |]@ | @'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\" . 'pathEnd'@ | 190 | -- +---------------------------------------+---------------------------------------------------------------------------------------------------+ 191 | -- | @[route| GET \/a\/b\/c |]@ | @'method' \@GET . 'path' \@\"\/a\/b\/c\" . 'pathEnd'@ | 192 | -- +---------------------------------------+---------------------------------------------------------------------------------------------------+ 193 | -- | @[route| GET \/a\/b\/objId:Int\/d |]@ | @'method' \@GET . 'path' \@\"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \@\"d\" . 'pathEnd'@ | 194 | -- +---------------------------------------+---------------------------------------------------------------------------------------------------+ 195 | -- 196 | route :: QuasiQuoter 197 | route = QuasiQuoter 198 | { quoteExp = toRouteExp 199 | , quotePat = const $ fail "route cannot be used in a pattern" 200 | , quoteType = const $ fail "route cannot be used in a type" 201 | , quoteDec = const $ fail "route cannot be used in a declaration" 202 | } 203 | 204 | toRouteExp :: String -> Q Exp 205 | toRouteExp s = do 206 | e <- toMatchExp s 207 | pure $ compose e (VarE 'pathEnd) 208 | 209 | toMatchExp :: String -> Q Exp 210 | toMatchExp s = case List.words s of 211 | [m, p] -> do 212 | let methodExp = AppTypeE (VarE 'method) (ConT $ mkName m) 213 | pathExps <- toPathExps p 214 | pure $ List.foldr1 compose $ methodExp :| pathExps 215 | [p] -> do 216 | pathExps <- toPathExps p 217 | pure $ List.foldr1 compose pathExps 218 | _ -> fail "Expected an HTTP method and a path or just a path" 219 | 220 | where 221 | toPathExps :: String -> Q [Exp] 222 | toPathExps p = splitOn '/' p 223 | & filter (/= "") 224 | & fmap (splitOn ':') 225 | & List.foldr joinPath [] 226 | & mapM toPathExp 227 | 228 | joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String] 229 | joinPath p [] = [p] 230 | joinPath (p:|[]) ((p':|[]) : xs) = ((p <> "/" <> p') :| []) : xs 231 | joinPath y (x:xs) = y:x:xs 232 | 233 | toPathExp :: NonEmpty String -> Q Exp 234 | toPathExp (p :| []) = pure $ AppTypeE (VarE 'path) (LitT $ StrTyLit p) 235 | toPathExp (v :| [t]) = pure $ AppTypeE (AppTypeE (VarE 'pathVar) (LitT $ StrTyLit v)) (ConT $ mkName t) 236 | toPathExp xs = fail $ "Invalid path component: " <> List.intercalate ":" (toList xs) 237 | 238 | compose :: Exp -> Exp -> Exp 239 | compose l = UInfixE l (VarE $ mkName ".") 240 | -------------------------------------------------------------------------------- /webgear-examples/realworld/Model/Article.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Model.Article 8 | ( CreateArticlePayload (..) 9 | , ArticleRecord (..) 10 | , create 11 | , getArticleBySlug 12 | , getArticleIdAndAuthorBySlug 13 | , UpdateArticlePayload (..) 14 | , Model.Article.update 15 | , Model.Article.delete 16 | , ArticleListInput (..) 17 | , articleList 18 | , ArticleFeedInput (..) 19 | , articleFeed 20 | , favorite 21 | , unfavorite 22 | ) where 23 | 24 | import Control.Exception.Safe (catch, throw) 25 | import Data.Aeson 26 | import Data.Char (isSpace) 27 | import Data.Maybe (fromJust) 28 | import qualified Data.Text as Text 29 | import Data.Time.Clock (UTCTime) 30 | import Data.Time.Clock.POSIX (getCurrentTime) 31 | import Database.Esqueleto as E 32 | import qualified Database.Persist.Sql as DB 33 | import Database.Sqlite (Error (..), SqliteException (..)) 34 | import Model.Common 35 | import Model.Entities 36 | import qualified Model.Profile as Profile 37 | import qualified Network.URI.Encode as URIEncode 38 | import Relude 39 | import System.Random (randomIO) 40 | 41 | 42 | data CreateArticlePayload = CreateArticlePayload 43 | { articleTitle :: Text 44 | , articleDescription :: Text 45 | , articleBody :: Text 46 | , articleTagList :: Maybe [Text] 47 | } 48 | deriving (Generic) 49 | 50 | instance FromJSON CreateArticlePayload where 51 | parseJSON = genericParseJSON dropPrefixOptions 52 | 53 | data ArticleRecord = ArticleRecord 54 | { articleSlug :: Text 55 | , articleTitle :: Text 56 | , articleDescription :: Text 57 | , articleBody :: Text 58 | , articleTagList :: [Text] 59 | , articleCreatedAt :: UTCTime 60 | , articleUpdatedAt :: UTCTime 61 | , articleFavorited :: Bool 62 | , articleFavoritesCount :: Int 63 | , articleAuthor :: Maybe Profile.Profile 64 | } 65 | deriving (Generic) 66 | 67 | instance ToJSON ArticleRecord where 68 | toJSON = genericToJSON dropPrefixOptions 69 | 70 | create :: Key User -> CreateArticlePayload -> DBAction ArticleRecord 71 | create userId CreateArticlePayload{..} = do 72 | articleCreatedAt <- liftIO getCurrentTime 73 | let articleUpdatedAt = articleCreatedAt 74 | articleAuthor = userId 75 | tags = fromMaybe [] articleTagList 76 | articleSlug <- slugify articleTitle 77 | 78 | articleId <- DB.insert Article{..} 79 | forM_ tags $ \tag -> do 80 | tagId <- DB.entityKey <$> DB.upsert (Tag tag) [] 81 | DB.insert $ ArticleTag tagId articleId 82 | 83 | fromJust <$> getArticleRecord (Just userId) articleId 84 | 85 | slugify :: MonadIO m => Text -> m Text 86 | slugify s = liftIO $ do 87 | num <- randomIO 88 | let suffix = "-" <> show (num :: Word64) 89 | pure $ (<> suffix) 90 | $ Text.take 255 91 | $ Text.filter URIEncode.isAllowed 92 | $ Text.map (\c -> if isSpace c then '-' else c) 93 | $ Text.toLower s 94 | 95 | getArticleRecord :: Maybe (Key User) -> Key Article -> DBAction (Maybe ArticleRecord) 96 | getArticleRecord maybeUserId articleId = DB.getEntity articleId >>= traverse (mkRecord maybeUserId) 97 | 98 | mkRecord :: Maybe (Key User) -> Entity Article -> DBAction ArticleRecord 99 | mkRecord maybeUserId (Entity articleId Article{..}) = do 100 | articleTagList <- map unValue <$> 101 | (select $ from $ 102 | \(articleTag, tag) -> do 103 | where_ (articleTag ^. ArticleTagArticleid ==. val articleId) 104 | where_ (articleTag ^. ArticleTagTagid ==. tag ^. TagId) 105 | pure (tag ^. TagName)) 106 | 107 | favoritedUsers <- map unValue <$> 108 | (select $ from $ 109 | \fav -> do 110 | where_ (fav ^. FavoriteArticleid ==. val articleId) 111 | pure $ fav ^. FavoriteUserid) 112 | let articleFavorited = maybe False (`elem` favoritedUsers) maybeUserId 113 | let articleFavoritesCount = length favoritedUsers 114 | authorProfile <- Profile.getOne maybeUserId articleAuthor 115 | 116 | pure $ ArticleRecord{articleAuthor = authorProfile, ..} 117 | 118 | 119 | -------------------------------------------------------------------------------- 120 | 121 | getArticleBySlug :: Maybe (Key User) -> Text -> DBAction (Maybe ArticleRecord) 122 | getArticleBySlug maybeUserId slug = 123 | DB.getBy (UniqueSlug slug) >>= traverse (mkRecord maybeUserId) 124 | 125 | 126 | -------------------------------------------------------------------------------- 127 | 128 | getArticleIdAndAuthorBySlug :: Text -> DBAction (Maybe (Key Article, Key User)) 129 | getArticleIdAndAuthorBySlug slug = do 130 | maybeResult <- listToMaybe <$> 131 | (select $ from $ 132 | \article -> do 133 | where_ (article ^. ArticleSlug ==. val slug) 134 | pure (article ^. ArticleId, article ^. ArticleAuthor)) 135 | pure $ fmap (\(Value aid, Value uid) -> (aid, uid)) maybeResult 136 | 137 | 138 | -------------------------------------------------------------------------------- 139 | 140 | data UpdateArticlePayload = UpdateArticlePayload 141 | { articleTitle :: Maybe Text 142 | , articleDescription :: Maybe Text 143 | , articleBody :: Maybe Text 144 | } 145 | deriving (Generic) 146 | 147 | instance FromJSON UpdateArticlePayload where 148 | parseJSON = genericParseJSON dropPrefixOptions 149 | 150 | update :: Key User -- ^ author 151 | -> Key Article 152 | -> UpdateArticlePayload 153 | -> DBAction (Maybe ArticleRecord) 154 | update authorId articleId UpdateArticlePayload{..} = do 155 | newSlug <- traverse slugify articleTitle 156 | now <- liftIO getCurrentTime 157 | let updates = catMaybes [ ArticleTitle =?. articleTitle 158 | , ArticleDescription =?. articleDescription 159 | , ArticleBody =?. articleBody 160 | , ArticleSlug =?. newSlug 161 | , ArticleUpdatedAt =?. Just now 162 | ] 163 | E.update $ \article -> do 164 | set article updates 165 | where_ (article ^. ArticleId ==. val articleId) 166 | where_ (article ^. ArticleAuthor ==. val authorId) 167 | 168 | getArticleRecord (Just authorId) articleId 169 | 170 | 171 | -------------------------------------------------------------------------------- 172 | 173 | delete :: Key User -> Text -> DBAction () 174 | delete userId slug = do 175 | let matchSlugAndAuthor article = do 176 | where_ (article ^. ArticleSlug ==. val slug) 177 | where_ (article ^. ArticleAuthor ==. val userId) 178 | 179 | E.delete $ from $ 180 | \articleTag -> 181 | where_ $ exists $ from $ 182 | \article -> do 183 | where_ (article ^. ArticleId ==. articleTag ^. ArticleTagArticleid) 184 | matchSlugAndAuthor article 185 | 186 | E.delete $ from $ 187 | \comment -> 188 | where_ $ exists $ from $ 189 | \article -> do 190 | where_ (article ^. ArticleId ==. comment ^. CommentArticle) 191 | matchSlugAndAuthor article 192 | 193 | E.delete $ from $ 194 | \fav -> 195 | where_ $ exists $ from $ 196 | \article -> do 197 | where_ (article ^. ArticleId ==. fav ^. FavoriteArticleid) 198 | matchSlugAndAuthor article 199 | 200 | E.delete $ from matchSlugAndAuthor 201 | 202 | 203 | -------------------------------------------------------------------------------- 204 | 205 | data ArticleListInput = ArticleListInput 206 | { maybeCurrentUserId :: Maybe (Key User) 207 | , maybeTag :: Maybe Text 208 | , maybeAuthorName :: Maybe Text 209 | , maybeFavoritedBy :: Maybe Text 210 | , listLimit :: Int64 211 | , listOffset :: Int64 212 | } 213 | 214 | articleList :: ArticleListInput -> DBAction [ArticleRecord] 215 | articleList ArticleListInput{..} = do 216 | let filterTag article = 217 | case maybeTag of 218 | Nothing -> val True 219 | Just "" -> val True 220 | Just aTag -> exists $ 221 | from $ \(articleTag, tag) -> do 222 | where_ (article ^. ArticleId ==. articleTag ^. ArticleTagArticleid) 223 | where_ (articleTag ^. ArticleTagTagid ==. tag ^. TagId) 224 | where_ (tag ^. TagName ==. val aTag) 225 | 226 | filterAuthor article = 227 | case maybeAuthorName of 228 | Nothing -> val True 229 | Just "" -> val True 230 | Just authorName -> exists $ 231 | from $ \user -> do 232 | where_ (article ^. ArticleAuthor ==. user ^. UserId) 233 | where_ (user ^. UserUsername ==. val authorName) 234 | 235 | filterFavorite article = 236 | case maybeFavoritedBy of 237 | Nothing -> val True 238 | Just "" -> val True 239 | Just favUserName -> exists $ 240 | from $ \(fav, user) -> do 241 | where_ (article ^. ArticleId ==. fav ^. FavoriteArticleid) 242 | where_ (fav ^. FavoriteUserid ==. user ^. UserId) 243 | where_ (user ^. UserUsername ==. val favUserName) 244 | 245 | articleIds <- select $ from $ 246 | \article -> do 247 | where_ (filterTag article) 248 | where_ (filterAuthor article) 249 | where_ (filterFavorite article) 250 | orderBy [desc $ article ^. ArticleUpdatedAt] 251 | limit listLimit 252 | offset listOffset 253 | pure $ article ^. ArticleId 254 | 255 | articles <- traverse (getArticleRecord maybeCurrentUserId . unValue) articleIds 256 | pure $ catMaybes articles 257 | 258 | 259 | -------------------------------------------------------------------------------- 260 | 261 | data ArticleFeedInput = ArticleFeedInput 262 | { currentUserId :: Key User 263 | , listLimit :: Int64 264 | , listOffset :: Int64 265 | } 266 | 267 | articleFeed :: ArticleFeedInput -> DBAction [ArticleRecord] 268 | articleFeed ArticleFeedInput{..} = do 269 | articleIds <- select $ from $ 270 | \(article, follow) -> do 271 | where_ (follow ^. FollowFollower ==. val currentUserId) 272 | where_ (follow ^. FollowFollowee ==. article ^. ArticleAuthor) 273 | orderBy [desc $ article ^. ArticleUpdatedAt] 274 | limit listLimit 275 | offset listOffset 276 | pure $ article ^. ArticleId 277 | 278 | articles <- traverse (getArticleRecord (Just currentUserId) . unValue) articleIds 279 | pure $ catMaybes articles 280 | 281 | 282 | -------------------------------------------------------------------------------- 283 | 284 | favorite :: Key User -> Text -> DBAction (Maybe ArticleRecord) 285 | favorite userId slug = getArticleIdAndAuthorBySlug slug >>= \case 286 | Nothing -> pure Nothing 287 | Just (articleId, _) -> do 288 | let fav = Favorite{favoriteUserid = userId, favoriteArticleid = articleId} 289 | let handleDBError :: SqliteException -> DBAction () 290 | handleDBError e | seError e == ErrorConstraint = pure () 291 | | otherwise = throw e 292 | DB.insert_ fav `catch` handleDBError 293 | getArticleRecord (Just userId) articleId 294 | 295 | 296 | -------------------------------------------------------------------------------- 297 | 298 | unfavorite :: Key User -> Text -> DBAction (Maybe ArticleRecord) 299 | unfavorite userId slug = getArticleIdAndAuthorBySlug slug >>= \case 300 | Nothing -> pure Nothing 301 | Just (articleId, _) -> do 302 | DB.deleteBy (UniqueFavorite articleId userId) 303 | getArticleRecord (Just userId) articleId 304 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Middlewares/Header.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Middlewares related to HTTP headers. 7 | -- 8 | module WebGear.Middlewares.Header 9 | ( -- * Traits 10 | Header 11 | , Header' (..) 12 | , HeaderNotFound (..) 13 | , HeaderParseError (..) 14 | , HeaderMatch 15 | , HeaderMatch' (..) 16 | , HeaderMismatch (..) 17 | 18 | -- * Middlewares 19 | , header 20 | , optionalHeader 21 | , lenientHeader 22 | , optionalLenientHeader 23 | , headerMatch 24 | , optionalHeaderMatch 25 | , requestContentTypeHeader 26 | , addResponseHeader 27 | ) where 28 | 29 | import Control.Arrow (Kleisli (..)) 30 | import Control.Monad ((>=>)) 31 | import Data.ByteString (ByteString) 32 | import qualified Data.ByteString.Lazy as LBS 33 | import Data.Kind (Type) 34 | import Data.Proxy (Proxy (..)) 35 | import Data.String (fromString) 36 | import Data.Text (Text) 37 | import Data.Void (Void, absurd) 38 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 39 | import Network.HTTP.Types (HeaderName) 40 | import Text.Printf (printf) 41 | import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) 42 | import WebGear.Modifiers (Existence (..), ParseStyle (..)) 43 | import WebGear.Trait (Linked, Trait (..), probe, unlink) 44 | import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..), 45 | ResponseMiddleware', badRequest400, requestHeader, setResponseHeader) 46 | 47 | 48 | -- | A 'Trait' for capturing an HTTP header of specified @name@ and 49 | -- converting it to some type @val@ via 'FromHttpApiData'. The 50 | -- modifiers @e@ and @p@ determine how missing headers and parsing 51 | -- errors are handled. The header name is compared case-insensitively. 52 | data Header' (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) = Header' 53 | 54 | -- | A 'Trait' for capturing a header with name @name@ in a request or 55 | -- response and convert it to some type @val@ via 'FromHttpApiData'. 56 | type Header (name :: Symbol) (val :: Type) = Header' Required Strict name val 57 | 58 | -- | Indicates a missing header 59 | data HeaderNotFound = HeaderNotFound 60 | deriving stock (Read, Show, Eq) 61 | 62 | -- | Error in converting a header 63 | newtype HeaderParseError = HeaderParseError Text 64 | deriving stock (Read, Show, Eq) 65 | 66 | deriveRequestHeader :: (KnownSymbol name, FromHttpApiData val) 67 | => Proxy name -> Linked ts Request -> (Maybe (Either Text val) -> r) -> r 68 | deriveRequestHeader proxy req cont = 69 | let s = fromString $ symbolVal proxy 70 | in cont $ parseHeader <$> requestHeader s (unlink req) 71 | 72 | 73 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) ts Request m where 74 | type Attribute (Header' Required Strict name val) Request = val 75 | type Absence (Header' Required Strict name val) Request = Either HeaderNotFound HeaderParseError 76 | 77 | tryLink :: Header' Required Strict name val 78 | -> Linked ts Request 79 | -> m (Either (Either HeaderNotFound HeaderParseError) val) 80 | tryLink _ r = pure $ deriveRequestHeader (Proxy @name) r $ \case 81 | Nothing -> Left $ Left HeaderNotFound 82 | Just (Left e) -> Left $ Right $ HeaderParseError e 83 | Just (Right x) -> Right x 84 | 85 | 86 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) ts Request m where 87 | type Attribute (Header' Optional Strict name val) Request = Maybe val 88 | type Absence (Header' Optional Strict name val) Request = HeaderParseError 89 | 90 | tryLink :: Header' Optional Strict name val 91 | -> Linked ts Request 92 | -> m (Either HeaderParseError (Maybe val)) 93 | tryLink _ r = pure $ deriveRequestHeader (Proxy @name) r $ \case 94 | Nothing -> Right Nothing 95 | Just (Left e) -> Left $ HeaderParseError e 96 | Just (Right x) -> Right $ Just x 97 | 98 | 99 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) ts Request m where 100 | type Attribute (Header' Required Lenient name val) Request = Either Text val 101 | type Absence (Header' Required Lenient name val) Request = HeaderNotFound 102 | 103 | tryLink :: Header' Required Lenient name val 104 | -> Linked ts Request 105 | -> m (Either HeaderNotFound (Either Text val)) 106 | tryLink _ r = pure $ deriveRequestHeader (Proxy @name) r $ \case 107 | Nothing -> Left HeaderNotFound 108 | Just (Left e) -> Right $ Left e 109 | Just (Right x) -> Right $ Right x 110 | 111 | 112 | instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) ts Request m where 113 | type Attribute (Header' Optional Lenient name val) Request = Maybe (Either Text val) 114 | type Absence (Header' Optional Lenient name val) Request = Void 115 | 116 | tryLink :: Header' Optional Lenient name val 117 | -> Linked ts Request 118 | -> m (Either Void (Maybe (Either Text val))) 119 | tryLink _ r = pure $ deriveRequestHeader (Proxy @name) r $ \case 120 | Nothing -> Right Nothing 121 | Just (Left e) -> Right $ Just $ Left e 122 | Just (Right x) -> Right $ Just $ Right x 123 | 124 | 125 | -- | A 'Trait' for ensuring that an HTTP header with specified @name@ 126 | -- has value @val@. The modifier @e@ determines how missing headers 127 | -- are handled. The header name is compared case-insensitively. 128 | data HeaderMatch' (e :: Existence) (name :: Symbol) (val :: Symbol) = HeaderMatch' 129 | 130 | -- | A 'Trait' for ensuring that a header with a specified @name@ has 131 | -- value @val@. 132 | type HeaderMatch (name :: Symbol) (val :: Symbol) = HeaderMatch' Required name val 133 | 134 | -- | Failure in extracting a header value 135 | data HeaderMismatch = HeaderMismatch 136 | { expectedHeader :: ByteString 137 | , actualHeader :: ByteString 138 | } 139 | deriving stock (Eq, Read, Show) 140 | 141 | 142 | instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Required name val) ts Request m where 143 | type Attribute (HeaderMatch' Required name val) Request = ByteString 144 | type Absence (HeaderMatch' Required name val) Request = Maybe HeaderMismatch 145 | 146 | tryLink :: HeaderMatch' Required name val 147 | -> Linked ts Request 148 | -> m (Either (Maybe HeaderMismatch) ByteString) 149 | tryLink _ r = pure $ 150 | let 151 | name = fromString $ symbolVal (Proxy @name) 152 | expected = fromString $ symbolVal (Proxy @val) 153 | in 154 | case requestHeader name (unlink r) of 155 | Nothing -> Left Nothing 156 | Just hv | hv == expected -> Right hv 157 | | otherwise -> Left $ Just HeaderMismatch {expectedHeader = expected, actualHeader = hv} 158 | 159 | instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Optional name val) ts Request m where 160 | type Attribute (HeaderMatch' Optional name val) Request = Maybe ByteString 161 | type Absence (HeaderMatch' Optional name val) Request = HeaderMismatch 162 | 163 | tryLink :: HeaderMatch' Optional name val 164 | -> Linked ts Request 165 | -> m (Either HeaderMismatch (Maybe ByteString)) 166 | tryLink _ r = pure $ 167 | let 168 | name = fromString $ symbolVal (Proxy @name) 169 | expected = fromString $ symbolVal (Proxy @val) 170 | in 171 | case requestHeader name (unlink r) of 172 | Nothing -> Right Nothing 173 | Just hv | hv == expected -> Right $ Just hv 174 | | otherwise -> Left $ HeaderMismatch {expectedHeader = expected, actualHeader = hv} 175 | 176 | 177 | -- | A middleware to extract a header value and convert it to a value 178 | -- of type @val@ using 'FromHttpApiData'. 179 | -- 180 | -- Example usage: 181 | -- 182 | -- > header @"Content-Length" @Integer handler 183 | -- 184 | -- The associated trait attribute has type @val@. A 400 Bad Request 185 | -- response is returned if the header is not found or could not be 186 | -- parsed. 187 | header :: forall name val m req a. 188 | (KnownSymbol name, FromHttpApiData val, MonadRouter m) 189 | => RequestMiddleware' m req (Header name val:req) a 190 | header handler = Kleisli $ 191 | probe Header' >=> either (errorResponse . mkError) (runKleisli handler) 192 | where 193 | headerName :: String 194 | headerName = symbolVal $ Proxy @name 195 | 196 | mkError :: Either HeaderNotFound HeaderParseError -> Response LBS.ByteString 197 | mkError (Left HeaderNotFound) = badRequest400 $ fromString $ printf "Could not find header %s" headerName 198 | mkError (Right (HeaderParseError _)) = badRequest400 $ fromString $ 199 | printf "Invalid value for header %s" headerName 200 | 201 | -- | A middleware to extract a header value and convert it to a value 202 | -- of type @val@ using 'FromHttpApiData'. 203 | -- 204 | -- Example usage: 205 | -- 206 | -- > optionalHeader @"Content-Length" @Integer handler 207 | -- 208 | -- The associated trait attribute has type @Maybe val@; a @Nothing@ 209 | -- value indicates that the header is missing from the request. A 400 210 | -- Bad Request response is returned if the header could not be parsed. 211 | optionalHeader :: forall name val m req a. 212 | (KnownSymbol name, FromHttpApiData val, MonadRouter m) 213 | => RequestMiddleware' m req (Header' Optional Strict name val:req) a 214 | optionalHeader handler = Kleisli $ 215 | probe Header' >=> either (errorResponse . mkError) (runKleisli handler) 216 | where 217 | headerName :: String 218 | headerName = symbolVal $ Proxy @name 219 | 220 | mkError :: HeaderParseError -> Response LBS.ByteString 221 | mkError (HeaderParseError _) = badRequest400 $ fromString $ 222 | printf "Invalid value for header %s" headerName 223 | 224 | -- | A middleware to extract a header value and convert it to a value 225 | -- of type @val@ using 'FromHttpApiData'. 226 | -- 227 | -- Example usage: 228 | -- 229 | -- > lenientHeader @"Content-Length" @Integer handler 230 | -- 231 | -- The associated trait attribute has type @Either Text val@. A 400 232 | -- Bad Request reponse is returned if the header is missing. The 233 | -- parsing is done leniently; the trait attribute is set to @Left 234 | -- Text@ in case of parse errors or @Right val@ on success. 235 | lenientHeader :: forall name val m req a. 236 | (KnownSymbol name, FromHttpApiData val, MonadRouter m) 237 | => RequestMiddleware' m req (Header' Required Lenient name val:req) a 238 | lenientHeader handler = Kleisli $ 239 | probe Header' >=> either (errorResponse . mkError) (runKleisli handler) 240 | where 241 | headerName :: String 242 | headerName = symbolVal $ Proxy @name 243 | 244 | mkError :: HeaderNotFound -> Response LBS.ByteString 245 | mkError HeaderNotFound = badRequest400 $ fromString $ printf "Could not find header %s" headerName 246 | 247 | -- | A middleware to extract an optional header value and convert it 248 | -- to a value of type @val@ using 'FromHttpApiData'. 249 | -- 250 | -- Example usage: 251 | -- 252 | -- > optionalLenientHeader @"Content-Length" @Integer handler 253 | -- 254 | -- The associated trait attribute has type @Maybe (Either Text 255 | -- val)@. This middleware never fails. 256 | optionalLenientHeader :: forall name val m req a. 257 | (KnownSymbol name, FromHttpApiData val, MonadRouter m) 258 | => RequestMiddleware' m req (Header' Optional Lenient name val:req) a 259 | optionalLenientHeader handler = Kleisli $ 260 | probe Header' >=> either absurd (runKleisli handler) 261 | 262 | -- | A middleware to ensure that a header in the request has a 263 | -- specific value. Fails the handler with a 400 Bad Request response 264 | -- if the header does not exist or does not match. 265 | headerMatch :: forall name val m req a. 266 | (KnownSymbol name, KnownSymbol val, MonadRouter m) 267 | => RequestMiddleware' m req (HeaderMatch name val:req) a 268 | headerMatch handler = Kleisli $ 269 | probe HeaderMatch' >=> either (errorResponse . mkError) (runKleisli handler) 270 | where 271 | headerName :: String 272 | headerName = symbolVal $ Proxy @name 273 | 274 | mkError :: Maybe HeaderMismatch -> Response LBS.ByteString 275 | mkError Nothing = badRequest400 $ fromString $ printf "Could not find header %s" headerName 276 | mkError (Just e) = badRequest400 $ fromString $ 277 | printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e) 278 | 279 | -- | A middleware to ensure that an optional header in the request has 280 | -- a specific value. Fails the handler with a 400 Bad Request response 281 | -- if the header has a different value. 282 | optionalHeaderMatch :: forall name val m req a. 283 | (KnownSymbol name, KnownSymbol val, MonadRouter m) 284 | => RequestMiddleware' m req (HeaderMatch' Optional name val:req) a 285 | optionalHeaderMatch handler = Kleisli $ 286 | probe HeaderMatch' >=> either (errorResponse . mkError) (runKleisli handler) 287 | where 288 | headerName :: String 289 | headerName = symbolVal $ Proxy @name 290 | 291 | mkError :: HeaderMismatch -> Response LBS.ByteString 292 | mkError e = badRequest400 $ fromString $ 293 | printf "Expected header %s to have value %s but found %s" headerName (show $ expectedHeader e) (show $ actualHeader e) 294 | 295 | -- | A middleware to check that the Content-Type header in the request 296 | -- has a specific value. It will fail the handler if the header did 297 | -- not match. 298 | -- 299 | -- Example usage: 300 | -- 301 | -- > requestContentTypeHeader @"application/json" handler 302 | -- 303 | requestContentTypeHeader :: forall val m req a. (KnownSymbol val, MonadRouter m) 304 | => RequestMiddleware' m req (HeaderMatch "Content-Type" val:req) a 305 | requestContentTypeHeader = headerMatch @"Content-Type" @val 306 | 307 | -- | A middleware to create or update a response header. 308 | -- 309 | -- Example usage: 310 | -- 311 | -- > addResponseHeader "Content-type" "application/json" handler 312 | -- 313 | addResponseHeader :: forall t m req a. (ToHttpApiData t, Monad m) 314 | => HeaderName -> t -> ResponseMiddleware' m req a a 315 | addResponseHeader name val handler = Kleisli $ runKleisli handler >=> pure . setResponseHeader name (toHeader val) 316 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright : (c) Raghu Kaippully, 2020-2021 3 | -- License : MPL-2.0 4 | -- Maintainer : rkaippully@gmail.com 5 | -- 6 | -- Common types and functions used throughout WebGear. 7 | -- 8 | module WebGear.Types 9 | ( -- * WebGear Request 10 | Request 11 | , remoteHost 12 | , httpVersion 13 | , isSecure 14 | , requestMethod 15 | , pathInfo 16 | , queryString 17 | , requestHeader 18 | , requestHeaders 19 | , requestBodyLength 20 | , getRequestBodyChunk 21 | 22 | -- * WebGear Response 23 | , Response (..) 24 | , responseHeader 25 | , setResponseHeader 26 | , waiResponse 27 | 28 | -- * Creating responses 29 | , respond 30 | , continue100 31 | , switchingProtocols101 32 | , ok200 33 | , created201 34 | , accepted202 35 | , nonAuthoritative203 36 | , noContent204 37 | , resetContent205 38 | , partialContent206 39 | , multipleChoices300 40 | , movedPermanently301 41 | , found302 42 | , seeOther303 43 | , notModified304 44 | , temporaryRedirect307 45 | , permanentRedirect308 46 | , badRequest400 47 | , unauthorized401 48 | , paymentRequired402 49 | , forbidden403 50 | , notFound404 51 | , methodNotAllowed405 52 | , notAcceptable406 53 | , proxyAuthenticationRequired407 54 | , requestTimeout408 55 | , conflict409 56 | , gone410 57 | , lengthRequired411 58 | , preconditionFailed412 59 | , requestEntityTooLarge413 60 | , requestURITooLong414 61 | , unsupportedMediaType415 62 | , requestedRangeNotSatisfiable416 63 | , expectationFailed417 64 | , imATeapot418 65 | , unprocessableEntity422 66 | , preconditionRequired428 67 | , tooManyRequests429 68 | , requestHeaderFieldsTooLarge431 69 | , internalServerError500 70 | , notImplemented501 71 | , badGateway502 72 | , serviceUnavailable503 73 | , gatewayTimeout504 74 | , httpVersionNotSupported505 75 | , networkAuthenticationRequired511 76 | 77 | -- * Handlers and Middlewares 78 | , Handler' 79 | , Handler 80 | , Middleware' 81 | , Middleware 82 | , RequestMiddleware' 83 | , RequestMiddleware 84 | , ResponseMiddleware' 85 | , ResponseMiddleware 86 | 87 | -- * Routing 88 | , Router (..) 89 | , MonadRouter (..) 90 | , PathInfo (..) 91 | , RouteError (..) 92 | , transform 93 | , runRoute 94 | , toApplication 95 | 96 | -- * Modifiers 97 | , Existence (..) 98 | , ParseStyle (..) 99 | ) where 100 | 101 | import Control.Applicative (Alternative) 102 | import Control.Arrow (Kleisli (..)) 103 | import Control.Exception.Safe (MonadCatch, MonadThrow) 104 | import Control.Monad (MonadPlus) 105 | import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError) 106 | import Control.Monad.IO.Class (MonadIO) 107 | import Control.Monad.State.Strict (MonadState, StateT, evalStateT) 108 | import Data.ByteString (ByteString) 109 | import Data.ByteString.Conversion.To (ToByteString, toByteString) 110 | import qualified Data.ByteString.Lazy as LBS 111 | import qualified Data.HashMap.Strict as HM 112 | import Data.List (find) 113 | import Data.Maybe (fromMaybe) 114 | import Data.Semigroup (Semigroup (..), stimesIdempotent) 115 | import Data.String (fromString) 116 | import Data.Text (Text) 117 | import Data.Version (showVersion) 118 | import GHC.Exts (fromList) 119 | import qualified Network.HTTP.Types as HTTP 120 | import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString, 121 | remoteHost, requestBodyLength, requestHeaders, requestMethod) 122 | import qualified Network.Wai as Wai 123 | import Paths_webgear_server (version) 124 | import WebGear.Modifiers (Existence (..), ParseStyle (..)) 125 | import WebGear.Trait (Linked, linkzero) 126 | 127 | 128 | -- | Get the value of a request header 129 | requestHeader :: HTTP.HeaderName -> Request -> Maybe ByteString 130 | requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r) 131 | 132 | -- | An HTTP response sent from the server to the client. 133 | -- 134 | -- The response contains a status, optional headers and an optional 135 | -- body of type @a@. 136 | data Response a = Response 137 | { responseStatus :: HTTP.Status -- ^ Response status code 138 | , responseHeaders :: HM.HashMap HTTP.HeaderName ByteString -- ^ Response headers 139 | , responseBody :: Maybe a -- ^ Optional response body 140 | } 141 | deriving stock (Eq, Ord, Show, Functor) 142 | 143 | -- | Looks up a response header 144 | responseHeader :: HTTP.HeaderName -> Response a -> Maybe ByteString 145 | responseHeader h = HM.lookup h . responseHeaders 146 | 147 | -- | Set a response header value 148 | setResponseHeader :: HTTP.HeaderName -> ByteString -> Response a -> Response a 149 | setResponseHeader name val r = r { responseHeaders = HM.insert name val (responseHeaders r) } 150 | 151 | -- | Convert a WebGear response to a WAI Response. 152 | waiResponse :: Response LBS.ByteString -> Wai.Response 153 | waiResponse Response{..} = Wai.responseLBS 154 | responseStatus 155 | (HM.toList responseHeaders) 156 | (fromMaybe "" responseBody) 157 | 158 | 159 | -- | Create a response with a given status and body 160 | respond :: HTTP.Status -> Maybe a -> Response a 161 | respond s = Response s mempty 162 | 163 | -- | Continue 100 response 164 | continue100 :: Response a 165 | continue100 = respond HTTP.continue100 Nothing 166 | 167 | -- | Switching Protocols 101 response 168 | switchingProtocols101 :: Response a 169 | switchingProtocols101 = respond HTTP.switchingProtocols101 Nothing 170 | 171 | -- | OK 200 response 172 | ok200 :: a -> Response a 173 | ok200 = respond HTTP.ok200 . Just 174 | 175 | -- | Created 201 response 176 | created201 :: a -> Response a 177 | created201 = respond HTTP.created201 . Just 178 | 179 | -- | Accepted 202 response 180 | accepted202 :: a -> Response a 181 | accepted202 = respond HTTP.accepted202 . Just 182 | 183 | -- | Non-Authoritative 203 response 184 | nonAuthoritative203 :: a -> Response a 185 | nonAuthoritative203 = respond HTTP.nonAuthoritative203 . Just 186 | 187 | -- | No Content 204 response 188 | noContent204 :: Response a 189 | noContent204 = respond HTTP.noContent204 Nothing 190 | 191 | -- | Reset Content 205 response 192 | resetContent205 :: Response a 193 | resetContent205 = respond HTTP.resetContent205 Nothing 194 | 195 | -- | Partial Content 206 response 196 | partialContent206 :: a -> Response a 197 | partialContent206 = respond HTTP.partialContent206 . Just 198 | 199 | -- | Multiple Choices 300 response 200 | multipleChoices300 :: a -> Response a 201 | multipleChoices300 = respond HTTP.multipleChoices300 . Just 202 | 203 | -- | Moved Permanently 301 response 204 | movedPermanently301 :: a -> Response a 205 | movedPermanently301 = respond HTTP.movedPermanently301 . Just 206 | 207 | -- | Found 302 response 208 | found302 :: a -> Response a 209 | found302 = respond HTTP.found302 . Just 210 | 211 | -- | See Other 303 response 212 | seeOther303 :: a -> Response a 213 | seeOther303 = respond HTTP.seeOther303 . Just 214 | 215 | -- | Not Modified 304 response 216 | notModified304 :: Response a 217 | notModified304 = respond HTTP.notModified304 Nothing 218 | 219 | -- | Temporary Redirect 307 response 220 | temporaryRedirect307 :: a -> Response a 221 | temporaryRedirect307 = respond HTTP.temporaryRedirect307 . Just 222 | 223 | -- | Permanent Redirect 308 response 224 | permanentRedirect308 :: a -> Response a 225 | permanentRedirect308 = respond HTTP.permanentRedirect308 . Just 226 | 227 | -- | Bad Request 400 response 228 | badRequest400 :: a -> Response a 229 | badRequest400 = respond HTTP.badRequest400 . Just 230 | 231 | -- | Unauthorized 401 response 232 | unauthorized401 :: a -> Response a 233 | unauthorized401 = respond HTTP.unauthorized401 . Just 234 | 235 | -- | Payment Required 402 response 236 | paymentRequired402 :: a -> Response a 237 | paymentRequired402 = respond HTTP.paymentRequired402 . Just 238 | 239 | -- | Forbidden 403 response 240 | forbidden403 :: a -> Response a 241 | forbidden403 = respond HTTP.forbidden403 . Just 242 | 243 | -- | Not Found 404 response 244 | notFound404 :: Response a 245 | notFound404 = respond HTTP.notFound404 Nothing 246 | 247 | -- | Method Not Allowed 405 response 248 | methodNotAllowed405 :: a -> Response a 249 | methodNotAllowed405 = respond HTTP.methodNotAllowed405 . Just 250 | 251 | -- | Not Acceptable 406 response 252 | notAcceptable406 :: a -> Response a 253 | notAcceptable406 = respond HTTP.notAcceptable406 . Just 254 | 255 | -- | Proxy Authentication Required 407 response 256 | proxyAuthenticationRequired407 :: a -> Response a 257 | proxyAuthenticationRequired407 = respond HTTP.proxyAuthenticationRequired407 . Just 258 | 259 | -- | Request Timeout 408 response 260 | requestTimeout408 :: a -> Response a 261 | requestTimeout408 = respond HTTP.requestTimeout408 . Just 262 | 263 | -- | Conflict 409 response 264 | conflict409 :: a -> Response a 265 | conflict409 = respond HTTP.conflict409 . Just 266 | 267 | -- | Gone 410 response 268 | gone410 :: a -> Response a 269 | gone410 = respond HTTP.gone410 . Just 270 | 271 | -- | Length Required 411 response 272 | lengthRequired411 :: a -> Response a 273 | lengthRequired411 = respond HTTP.lengthRequired411 . Just 274 | 275 | -- | Precondition Failed 412 response 276 | preconditionFailed412 :: a -> Response a 277 | preconditionFailed412 = respond HTTP.preconditionFailed412 . Just 278 | 279 | -- | Request Entity Too Large 413 response 280 | requestEntityTooLarge413 :: a -> Response a 281 | requestEntityTooLarge413 = respond HTTP.requestEntityTooLarge413 . Just 282 | 283 | -- | Request URI Too Long 414 response 284 | requestURITooLong414 :: a -> Response a 285 | requestURITooLong414 = respond HTTP.requestURITooLong414 . Just 286 | 287 | -- | Unsupported Media Type 415 response 288 | unsupportedMediaType415 :: a -> Response a 289 | unsupportedMediaType415 = respond HTTP.unsupportedMediaType415 . Just 290 | 291 | -- | Requested Range Not Satisfiable 416 response 292 | requestedRangeNotSatisfiable416 :: a -> Response a 293 | requestedRangeNotSatisfiable416 = respond HTTP.requestedRangeNotSatisfiable416 . Just 294 | 295 | -- | Expectation Failed 417 response 296 | expectationFailed417 :: a -> Response a 297 | expectationFailed417 = respond HTTP.expectationFailed417 . Just 298 | 299 | -- | I'm A Teapot 418 response 300 | imATeapot418 :: a -> Response a 301 | imATeapot418 = respond HTTP.imATeapot418 . Just 302 | 303 | -- | Unprocessable Entity 422 response 304 | unprocessableEntity422 :: a -> Response a 305 | unprocessableEntity422 = respond HTTP.unprocessableEntity422 . Just 306 | 307 | -- | Precondition Required 428 response 308 | preconditionRequired428 :: a -> Response a 309 | preconditionRequired428 = respond HTTP.preconditionRequired428 . Just 310 | 311 | -- | Too Many Requests 429 response 312 | tooManyRequests429 :: a -> Response a 313 | tooManyRequests429 = respond HTTP.tooManyRequests429 . Just 314 | 315 | -- | Request Header Fields Too Large 431 response 316 | requestHeaderFieldsTooLarge431 :: a -> Response a 317 | requestHeaderFieldsTooLarge431 = respond HTTP.requestHeaderFieldsTooLarge431 . Just 318 | 319 | -- | Internal Server Error 500 response 320 | internalServerError500 :: a -> Response a 321 | internalServerError500 = respond HTTP.internalServerError500 . Just 322 | 323 | -- | Not Implemented 501 response 324 | notImplemented501 :: a -> Response a 325 | notImplemented501 = respond HTTP.notImplemented501 . Just 326 | 327 | -- | Bad Gateway 502 response 328 | badGateway502 :: a -> Response a 329 | badGateway502 = respond HTTP.badGateway502 . Just 330 | 331 | -- | Service Unavailable 503 response 332 | serviceUnavailable503 :: a -> Response a 333 | serviceUnavailable503 = respond HTTP.serviceUnavailable503 . Just 334 | 335 | -- | Gateway Timeout 504 response 336 | gatewayTimeout504 :: a -> Response a 337 | gatewayTimeout504 = respond HTTP.gatewayTimeout504 . Just 338 | 339 | -- | HTTP Version Not Supported 505 response 340 | httpVersionNotSupported505 :: a -> Response a 341 | httpVersionNotSupported505 = respond HTTP.httpVersionNotSupported505 . Just 342 | 343 | -- | Network Authentication Required 511 response 344 | networkAuthenticationRequired511 :: a -> Response a 345 | networkAuthenticationRequired511 = respond HTTP.networkAuthenticationRequired511 . Just 346 | 347 | 348 | 349 | -- | A handler is a function from a request to response in a monadic 350 | -- context. Both the request and the response can have linked traits. 351 | -- 352 | -- The type level list @req@ contains all the traits expected to be 353 | -- present in the request. 354 | type Handler' m req a = Kleisli m (Linked req Request) (Response a) 355 | 356 | -- | A handler that runs on the 'Router' monad. 357 | type Handler req a = Handler' Router req a 358 | 359 | -- | A middleware takes a handler as input and produces another 360 | -- handler that usually adds some functionality. 361 | -- 362 | -- A middleware can do a number of things with the request 363 | -- handling such as: 364 | -- 365 | -- * Change the request traits before invoking the handler. 366 | -- * Use the linked value of any of the request traits. 367 | -- * Change the response body. 368 | -- 369 | type Middleware' m req req' a' a = Handler' m req' a' -> Handler' m req a 370 | 371 | -- | A middleware that runs on the 'Router' monad. 372 | type Middleware req req' a' a = Middleware' Router req req' a' a 373 | 374 | -- | A middleware that manipulates only the request traits and passes 375 | -- the response through. 376 | type RequestMiddleware' m req req' a = Middleware' m req req' a a 377 | 378 | -- | A request middleware that runs on the 'Router' monad. 379 | type RequestMiddleware req req' a = RequestMiddleware' Router req req' a 380 | 381 | -- | A middleware that manipulates only the response and passes the 382 | -- request through. 383 | type ResponseMiddleware' m req a' a = Middleware' m req req a' a 384 | 385 | -- | A response middleware that runs on the 'Router' monad. 386 | type ResponseMiddleware req a' a = ResponseMiddleware' Router req a' a 387 | 388 | -- | A natural transformation of handler monads. 389 | -- 390 | -- This is useful if you want to run a handler in a monad other than 391 | -- 'Router'. 392 | -- 393 | transform :: (forall x. m x -> n x) -> Handler' m req a -> Handler' n req a 394 | transform f (Kleisli mf) = Kleisli $ f . mf 395 | 396 | -- | The path components to be matched by routing machinery 397 | newtype PathInfo = PathInfo [Text] 398 | 399 | -- | Responses that cause routes to abort execution 400 | data RouteError = RouteMismatch 401 | -- ^ A route did not match and the next one can be 402 | -- tried 403 | | ErrorResponse (Response LBS.ByteString) 404 | -- ^ A route matched but returned a short circuiting 405 | -- error response 406 | deriving (Eq, Ord, Show) 407 | 408 | instance Semigroup RouteError where 409 | RouteMismatch <> e = e 410 | e <> _ = e 411 | 412 | stimes :: Integral b => b -> RouteError -> RouteError 413 | stimes = stimesIdempotent 414 | 415 | instance Monoid RouteError where 416 | mempty = RouteMismatch 417 | 418 | -- | The monad for routing. 419 | newtype Router a = Router 420 | { unRouter :: StateT PathInfo (ExceptT RouteError IO) a } 421 | deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus 422 | , MonadError RouteError 423 | , MonadState PathInfo 424 | , MonadIO 425 | , MonadThrow, MonadCatch 426 | ) 427 | 428 | -- | HTTP request routing with short circuiting behavior. 429 | class (MonadState PathInfo m, Alternative m, MonadPlus m) => MonadRouter m where 430 | -- | Mark the current route as rejected, alternatives can be tried 431 | rejectRoute :: m a 432 | 433 | -- | Short-circuit the current handler and return a response 434 | errorResponse :: Response LBS.ByteString -> m a 435 | 436 | -- | Handle an error response 437 | catchErrorResponse :: m a -> (Response LBS.ByteString -> m a) -> m a 438 | 439 | instance MonadRouter Router where 440 | rejectRoute :: Router a 441 | rejectRoute = throwError RouteMismatch 442 | 443 | errorResponse :: Response LBS.ByteString -> Router a 444 | errorResponse = throwError . ErrorResponse 445 | 446 | catchErrorResponse :: Router a -> (Response LBS.ByteString -> Router a) -> Router a 447 | catchErrorResponse action handle = action `catchError` f 448 | where 449 | f RouteMismatch = rejectRoute 450 | f (ErrorResponse res) = handle res 451 | 452 | 453 | -- | Convert a routable handler into a plain function from request to response. 454 | runRoute :: ToByteString a => Handler '[] a -> (Wai.Request -> IO Wai.Response) 455 | runRoute route req = waiResponse . addServerHeader . either routeErrorToResponse id <$> runRouter 456 | where 457 | runRouter :: IO (Either RouteError (Response LBS.ByteString)) 458 | runRouter = fmap (fmap (fmap toByteString)) 459 | $ runExceptT 460 | $ flip evalStateT (PathInfo $ pathInfo req) 461 | $ unRouter 462 | $ runKleisli route 463 | $ linkzero req 464 | 465 | routeErrorToResponse :: RouteError -> Response LBS.ByteString 466 | routeErrorToResponse RouteMismatch = notFound404 467 | routeErrorToResponse (ErrorResponse r) = r 468 | 469 | addServerHeader :: Response LBS.ByteString -> Response LBS.ByteString 470 | addServerHeader r = r { responseHeaders = responseHeaders r <> fromList [serverHeader] } 471 | 472 | serverHeader :: HTTP.Header 473 | serverHeader = (HTTP.hServer, fromString $ "WebGear/" ++ showVersion version) 474 | 475 | -- | Convert a routable handler into a Wai application 476 | toApplication :: ToByteString a => Handler '[] a -> Wai.Application 477 | toApplication route request next = runRoute route request >>= next 478 | --------------------------------------------------------------------------------