├── _config.yml ├── Setup.hs ├── test ├── Spec.hs └── HelloSpec.hs ├── examples ├── bare-wai │ ├── Setup.hs │ ├── bare-wai-example.cabal │ └── src │ │ └── Main.hs ├── blaze-html │ ├── Setup.hs │ ├── blaze-html-example.cabal │ └── src │ │ └── Main.hs ├── hello-world │ ├── Setup.hs │ ├── static │ │ └── lambda.png │ ├── hello-world-example.cabal │ └── src │ │ └── Main.hs ├── kitchen │ ├── Setup.hs │ ├── kitchen-example.cabal │ └── src │ │ └── Main.hs ├── rest-json │ ├── Setup.hs │ ├── rest-json-example.cabal │ └── src │ │ ├── PersonCrud.hs │ │ └── Main.hs ├── shakespeare │ ├── Setup.hs │ ├── templates │ │ └── home.hamlet │ ├── shakespeare-example.cabal │ └── src │ │ └── Main.hs ├── subsites │ ├── Setup.hs │ ├── subsites-example.cabal │ └── src │ │ ├── HelloSub.hs │ │ └── Main.hs ├── unrouted │ ├── Setup.hs │ ├── static │ │ └── lambda.png │ ├── unrouted-example.cabal │ └── src │ │ └── Main.hs ├── streaming-response │ ├── Setup.hs │ ├── streaming-response-example.cabal │ └── src │ │ └── Main.hs └── digestive-functors-hamlet │ ├── Setup.hs │ ├── digestive-functors-hamlet-example.cabal │ └── src │ └── Main.hs ├── benchmark └── result-tama.png ├── .gitignore ├── shell.nix ├── src ├── Routes │ ├── TH.hs │ ├── Class.hs │ ├── DefaultRoute.hs │ ├── TH │ │ ├── RouteAttrs.hs │ │ ├── ParseRoute.hs │ │ ├── Types.hs │ │ ├── RenderRoute.hs │ │ └── Dispatch.hs │ ├── ContentTypes.hs │ ├── Overlap.hs │ ├── Monad.hs │ ├── Parse.hs │ ├── Routes.hs │ └── Handler.hs ├── Network │ └── Wai │ │ └── Middleware │ │ └── Routes.hs ├── Util │ └── Free.hs └── Wai │ └── Routes.hs ├── stack.yaml ├── default.nix ├── LICENSE ├── .github └── workflows │ └── haskell.yml ├── wai-routes.cabal ├── .travis.yml └── README.md /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-cayman -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /examples/bare-wai/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/blaze-html/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/hello-world/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/kitchen/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/rest-json/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/shakespeare/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/subsites/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/unrouted/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/streaming-response/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/digestive-functors-hamlet/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmark/result-tama.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ajnsit/wai-routes/HEAD/benchmark/result-tama.png -------------------------------------------------------------------------------- /examples/unrouted/static/lambda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ajnsit/wai-routes/HEAD/examples/unrouted/static/lambda.png -------------------------------------------------------------------------------- /examples/hello-world/static/lambda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ajnsit/wai-routes/HEAD/examples/hello-world/static/lambda.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | dist 3 | *~ 4 | tmp 5 | _darcs 6 | *.old.hs 7 | *.hi 8 | *.o 9 | tags 10 | cabal.config 11 | cabal.sandbox.config 12 | .cabal-sandbox 13 | .stack-work 14 | dist-stack 15 | vendor 16 | 17 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | {nixpkgs ? import {}, compiler ? "default"}: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | 5 | haskellPackages = if compiler == "default" 6 | then pkgs.haskellPackages 7 | else pkgs.haskell.packages.${compiler}; 8 | 9 | f = import ./.; 10 | drv = haskellPackages.callPackage f {}; 11 | 12 | in if pkgs.lib.inNixShell then drv.env else drv 13 | -------------------------------------------------------------------------------- /src/Routes/TH.hs: -------------------------------------------------------------------------------- 1 | module Routes.TH 2 | ( module Routes.TH.Types 3 | -- * Functions 4 | , module Routes.TH.RenderRoute 5 | , module Routes.TH.ParseRoute 6 | , module Routes.TH.RouteAttrs 7 | -- ** Dispatch 8 | , module Routes.TH.Dispatch 9 | ) where 10 | 11 | import Routes.TH.Types 12 | import Routes.TH.RenderRoute 13 | import Routes.TH.ParseRoute 14 | import Routes.TH.RouteAttrs 15 | import Routes.TH.Dispatch 16 | -------------------------------------------------------------------------------- /examples/shakespeare/templates/home.hamlet: -------------------------------------------------------------------------------- 1 | $doctype 5 2 | 3 | 4 | #{pageTitle} - My Site 5 | <link rel=stylesheet href=@{StylesheetR}> 6 | <body> 7 | <h1 .page-title>#{pageTitle} 8 | <p>Here is a list of your friends: 9 | $if null people 10 | <p>Sorry, I lied, you don't have any friends. 11 | $else 12 | <ul> 13 | $forall Person name age <- people 14 | <li>#{name} (#{age} years old) 15 | <footer>^{copyright} 16 | -------------------------------------------------------------------------------- /src/Network/Wai/Middleware/Routes.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Network.Wai.Middleware.Routes 3 | Copyright : (c) Anupam Jain 2013 4 | License : MIT (see the file LICENSE) 5 | 6 | Maintainer : ajnsit@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (uses ghc extensions) 9 | 10 | This package provides typesafe URLs for Wai applications. 11 | 12 | * Deprecated*: Use Wai.Routes instead. 13 | -} 14 | module Network.Wai.Middleware.Routes {-# DEPRECATED "Use Wai.Routes instead" #-} 15 | ( module Wai.Routes ) 16 | where 17 | 18 | import Wai.Routes 19 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | - examples/hello-world 5 | - examples/subsites 6 | - examples/blaze-html 7 | - examples/shakespeare 8 | - examples/digestive-functors-hamlet 9 | - examples/rest-json 10 | - examples/streaming-response 11 | - examples/kitchen 12 | - examples/unrouted 13 | - examples/bare-wai 14 | extra-deps: 15 | # Needed for the digestive-functors-hamlet example 16 | - digestive-functors-0.8.4.0 17 | - digestive-functors-blaze-0.6.2.0 18 | - http-types-0.12.1 19 | - safe-exceptions-0.1.7.0 20 | - semigroups-0.18.5@sha256:41ef9f5f183f66c519c5cddcb3fbfdbc9b67a2b7bfae7d81f91de9ff7367d8c6,5828 21 | resolver: lts-16.12 22 | -------------------------------------------------------------------------------- /examples/kitchen/kitchen-example.cabal: -------------------------------------------------------------------------------- 1 | name : kitchen-example 2 | version : 0.8.1 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Kitchen sink example for wai-routes 8 | description : Kitchen sink example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable kitchen-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , warp 17 | , text 18 | main-is : Main.hs 19 | buildable : True 20 | default-language : Haskell2010 21 | ghc-options : -Wall 22 | hs-source-dirs : src 23 | -------------------------------------------------------------------------------- /examples/blaze-html/blaze-html-example.cabal: -------------------------------------------------------------------------------- 1 | name : blaze-html-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Blaze-Html example for wai-routes 8 | description : Blaze-Html example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable blaze-html-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , wai-extra 17 | , wai-app-static 18 | , warp 19 | , text 20 | , blaze-html 21 | main-is : Main.hs 22 | default-language : Haskell2010 23 | ghc-options : -Wall 24 | hs-source-dirs : src 25 | -------------------------------------------------------------------------------- /examples/hello-world/hello-world-example.cabal: -------------------------------------------------------------------------------- 1 | name : hello-world-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Hello world example for wai-routes 8 | description : Hello world example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable hello-world-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai 16 | , wai-routes 17 | , wai-extra 18 | , wai-app-static 19 | , warp 20 | , text 21 | main-is : Main.hs 22 | buildable : True 23 | default-language : Haskell2010 24 | ghc-options : -Wall 25 | hs-source-dirs : src 26 | -------------------------------------------------------------------------------- /examples/bare-wai/bare-wai-example.cabal: -------------------------------------------------------------------------------- 1 | name : bare-wai-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Bare wai example for wai-routes 8 | description : Bare wai example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable bare-wai-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai 16 | , wai-routes 17 | , wai-extra 18 | , wai-app-static 19 | , warp 20 | , text 21 | , bytestring 22 | main-is : Main.hs 23 | buildable : True 24 | default-language : Haskell2010 25 | ghc-options : -Wall 26 | hs-source-dirs : src 27 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, blaze-builder, bytestring 2 | , case-insensitive, containers, cookie, data-default-class 3 | , filepath, hspec, hspec-wai, hspec-wai-json, http-types 4 | , mime-types, monad-loops, mtl, path-pieces, random, stdenv 5 | , template-haskell, text, vault, wai, wai-extra 6 | }: 7 | mkDerivation { 8 | pname = "wai-routes"; 9 | version = "0.10.4"; 10 | src = ./.; 11 | libraryHaskellDepends = [ 12 | aeson base blaze-builder bytestring case-insensitive containers 13 | cookie data-default-class filepath http-types mime-types 14 | monad-loops mtl path-pieces random template-haskell text vault wai 15 | wai-extra 16 | ]; 17 | testHaskellDepends = [ 18 | aeson base hspec hspec-wai hspec-wai-json text wai 19 | ]; 20 | homepage = "https://ajnsit.github.io/wai-routes/"; 21 | description = "Typesafe URLs for Wai applications"; 22 | license = stdenv.lib.licenses.mit; 23 | } 24 | -------------------------------------------------------------------------------- /src/Util/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, DeriveFunctor #-} 2 | module Util.Free ( 3 | F(..), 4 | liftF 5 | ) where 6 | 7 | import Control.Applicative (Applicative, (<*>), pure) 8 | 9 | -- Free Monad 10 | newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } 11 | instance Functor f => Functor (F f) where 12 | fmap f (F g) = F (\kp -> g (kp . f)) 13 | instance Functor f => Applicative (F f) where 14 | pure a = F (\kp _ -> kp a) 15 | F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf) 16 | instance Functor f => Monad (F f) where 17 | return a = F (\kp _ -> kp a) 18 | F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) 19 | 20 | -- | Add a layer 21 | wrap :: Functor f => f (F f a) -> F f a 22 | wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f)) 23 | 24 | -- | A version of lift that can be used with just a Functor for f. 25 | liftF :: Functor f => f a -> F f a 26 | liftF = wrap . fmap return 27 | -- End free monad things 28 | -------------------------------------------------------------------------------- /examples/streaming-response/streaming-response-example.cabal: -------------------------------------------------------------------------------- 1 | name : streaming-response-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Streaming response example for wai-routes 8 | description : Streaming response example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable streaming-response-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai 16 | , wai-routes 17 | , wai-extra 18 | , wai-app-static 19 | , warp 20 | , bytestring 21 | , transformers 22 | main-is : Main.hs 23 | buildable : True 24 | default-language : Haskell2010 25 | ghc-options : -Wall 26 | hs-source-dirs : src 27 | -------------------------------------------------------------------------------- /examples/unrouted/unrouted-example.cabal: -------------------------------------------------------------------------------- 1 | name : unrouted-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Using "unrouted" handlers example for wai-routes 8 | description : Using "unrouted" handlers example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable unrouted-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai 16 | , wai-routes 17 | , wai-extra 18 | , wai-app-static 19 | , warp 20 | , text 21 | , transformers 22 | , vault 23 | main-is : Main.hs 24 | buildable : True 25 | default-language : Haskell2010 26 | ghc-options : -Wall 27 | hs-source-dirs : src 28 | -------------------------------------------------------------------------------- /examples/subsites/subsites-example.cabal: -------------------------------------------------------------------------------- 1 | name : subsites-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Subsites examples for wai-routes 8 | description : Subsites examples for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable subsites-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , wai-app-static 17 | , wai-extra 18 | , warp 19 | , http-types 20 | , text 21 | , aeson 22 | , containers 23 | , mtl 24 | main-is : Main.hs 25 | other-modules : HelloSub 26 | buildable : True 27 | default-language : Haskell2010 28 | ghc-options : -Wall 29 | hs-source-dirs : src 30 | -------------------------------------------------------------------------------- /examples/rest-json/rest-json-example.cabal: -------------------------------------------------------------------------------- 1 | name : rest-json-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : REST JSON example for wai-routes 8 | description : REST JSON example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable rest-json-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , wai-extra 17 | , wai-app-static 18 | , warp 19 | , http-types 20 | , text 21 | , aeson 22 | , containers 23 | , transformers 24 | main-is : Main.hs 25 | other-modules : PersonCrud 26 | buildable : True 27 | default-language : Haskell2010 28 | ghc-options : -Wall 29 | hs-source-dirs : src 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Anupam Jain 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /examples/shakespeare/shakespeare-example.cabal: -------------------------------------------------------------------------------- 1 | name : shakespeare-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Shakespearean templates example for wai-routes 8 | description : Shakespearean templates example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable shakespeare-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , wai-extra 17 | , wai-app-static 18 | , warp 19 | , text 20 | , shakespeare 21 | , blaze-html 22 | main-is : Main.hs 23 | buildable : True 24 | default-language : Haskell2010 25 | other-extensions : OverloadedStrings TemplateHaskell QuasiQuotes TypeFamilies ViewPatterns 26 | ghc-options : -Wall 27 | hs-source-dirs : src 28 | -------------------------------------------------------------------------------- /src/Routes/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Routes.Class 4 | ( RenderRoute (..) 5 | , ParseRoute (..) 6 | , RouteAttrs (..) 7 | ) where 8 | 9 | import Data.Text (Text) 10 | import Data.Set (Set) 11 | 12 | class Eq (Route a) => RenderRoute a where 13 | -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument. 14 | data Route a 15 | renderRoute :: Route a 16 | -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. 17 | 18 | class RenderRoute a => ParseRoute a where 19 | parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. 20 | -> Maybe (Route a) 21 | 22 | class RenderRoute a => RouteAttrs a where 23 | routeAttrs :: Route a 24 | -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>. 25 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | - uses: actions/setup-haskell@v1 20 | with: 21 | ghc-version: '8.10.3' 22 | cabal-version: '3.2' 23 | 24 | - name: Cache 25 | uses: actions/cache@v3 26 | env: 27 | cache-name: cache-cabal 28 | with: 29 | path: ~/.cabal 30 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 31 | restore-keys: | 32 | ${{ runner.os }}-build-${{ env.cache-name }}- 33 | ${{ runner.os }}-build- 34 | ${{ runner.os }}- 35 | 36 | - name: Install dependencies 37 | run: | 38 | cabal update 39 | cabal build --only-dependencies --enable-tests --enable-benchmarks 40 | - name: Build 41 | run: cabal build --enable-tests --enable-benchmarks all 42 | - name: Run tests 43 | run: cabal test all 44 | -------------------------------------------------------------------------------- /examples/digestive-functors-hamlet/digestive-functors-hamlet-example.cabal: -------------------------------------------------------------------------------- 1 | name : digestive-functors-hamlet-example 2 | version : 0.8.0 3 | cabal-version : >=1.16 4 | build-type : Simple 5 | license : PublicDomain 6 | maintainer : ajnsit@gmail.com 7 | synopsis : Digestive-functors + hamlet example for wai-routes 8 | description : Digestive-functors + hamlet example for wai-routes 9 | category : Web 10 | author : Anupam Jain 11 | data-dir : "" 12 | 13 | executable digestive-functors-hamlet-example 14 | build-depends : base >= 4.7 && < 5 15 | , wai-routes 16 | , wai-extra 17 | , wai-app-static 18 | , warp 19 | , text 20 | , shakespeare 21 | , blaze-html 22 | , digestive-functors 23 | , digestive-functors-blaze 24 | main-is : Main.hs 25 | buildable : True 26 | default-language : Haskell2010 27 | other-extensions : OverloadedStrings TemplateHaskell QuasiQuotes TypeFamilies ViewPatterns 28 | ghc-options : -Wall 29 | hs-source-dirs : src 30 | -------------------------------------------------------------------------------- /src/Routes/DefaultRoute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | {- | 4 | Module : Routes.DefaultRoute 5 | Copyright : (c) Anupam Jain 2013 - 2015 6 | License : MIT (see the file LICENSE) 7 | 8 | Maintainer : ajnsit@gmail.com 9 | Stability : experimental 10 | Portability : non-portable (uses ghc extensions) 11 | 12 | Defines a DefaultMaster datatype and associated route (DefaultRoute) which is used for "unrouted" handlers 13 | -} 14 | module Routes.DefaultRoute 15 | ( DefaultMaster(..) 16 | , Route(DefaultRoute) 17 | ) 18 | where 19 | 20 | import Data.Text (Text) 21 | import Data.Set (empty) 22 | 23 | import Routes.Routes 24 | 25 | -- Default master datatype, which is used for "unrouted" handlers 26 | data DefaultMaster = DefaultMaster deriving (Eq, Show, Ord) 27 | -- This makes it possible to define handlers without routing stuff 28 | instance RenderRoute DefaultMaster where 29 | -- The associated route simply contains all path information 30 | data Route DefaultMaster = DefaultRoute ([Text],[(Text, Text)]) deriving (Eq, Show, Ord) 31 | renderRoute (DefaultRoute r) = r 32 | instance ParseRoute DefaultMaster where 33 | parseRoute = Just . DefaultRoute 34 | instance RouteAttrs DefaultMaster where 35 | routeAttrs = const empty 36 | -------------------------------------------------------------------------------- /src/Routes/TH/RouteAttrs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Routes.TH.RouteAttrs 4 | ( mkRouteAttrsInstance 5 | ) where 6 | 7 | import Routes.TH.Types 8 | import Routes.Class 9 | import Language.Haskell.TH.Syntax 10 | import Data.Set (fromList) 11 | import Data.Text (pack) 12 | 13 | mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec 14 | mkRouteAttrsInstance cxt typ ress = do 15 | clauses <- mapM (goTree id) ress 16 | return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ) 17 | [ FunD 'routeAttrs $ concat clauses 18 | ] 19 | 20 | goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] 21 | goTree front (ResourceLeaf res) = return <$> goRes front res 22 | goTree front (ResourceParent name _check pieces trees) = 23 | concat <$> mapM (goTree front') trees 24 | where 25 | ignored = (replicate toIgnore WildP ++) . return 26 | toIgnore = length $ filter isDynamic pieces 27 | isDynamic Dynamic{} = True 28 | isDynamic Static{} = False 29 | front' = front . ConP (mkName name) . ignored 30 | 31 | goRes :: (Pat -> Pat) -> Resource a -> Q Clause 32 | goRes front Resource {..} = 33 | return $ Clause 34 | [front $ RecP (mkName resourceName) []] 35 | (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) 36 | [] 37 | where 38 | toText s = VarE 'pack `AppE` LitE (StringL s) 39 | 40 | instanceD :: Cxt -> Type -> [Dec] -> Dec 41 | instanceD = InstanceD Nothing 42 | -------------------------------------------------------------------------------- /examples/streaming-response/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} 2 | module Main where 3 | {- 4 | A demonstration of streaming response body. 5 | Note: Most browsers will NOT display the streaming contents as is. 6 | Try CURL to see the effect of streaming. "curl localhost:8080" 7 | -} 8 | 9 | import Wai.Routes 10 | import Network.Wai.Handler.Warp 11 | import Network.Wai.Application.Static 12 | 13 | import Control.Monad (forM_) 14 | import Control.Monad.IO.Class (liftIO) 15 | import Control.Concurrent (threadDelay) 16 | 17 | import Data.ByteString.Builder (intDec) 18 | 19 | -- The Master Site argument 20 | data MyRoute = MyRoute 21 | 22 | -- Generate routing code 23 | mkRoute "MyRoute" [parseRoutes| 24 | / HomeR GET 25 | |] 26 | 27 | -- Handlers 28 | 29 | -- Homepage 30 | getHomeR :: Handler MyRoute 31 | getHomeR = runHandlerM $ stream $ \write flush -> do 32 | write "Starting Countdown\n" 33 | flush 34 | forM_ (reverse [1..10]) $ \n -> do 35 | liftIO $ threadDelay 1000000 36 | write $ intDec n 37 | write "\n" 38 | flush 39 | write "Done!\n" 40 | 41 | -- The application that uses our route 42 | -- NOTE: We use the Route Monad to simplify routing 43 | application :: RouteM () 44 | application = do 45 | middleware logStdoutDev 46 | route MyRoute 47 | catchall $ staticApp $ defaultFileServerSettings "static" 48 | 49 | -- Run the application 50 | main :: IO () 51 | main = do 52 | putStrLn "Starting server on port 8080" 53 | run 8080 $ waiApp application 54 | -------------------------------------------------------------------------------- /examples/rest-json/src/PersonCrud.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, TemplateHaskell #-} 2 | {- CRUD operations for PersonRoute. See Main.hs for full code. -} 3 | module PersonCrud where 4 | 5 | import Data.Text (Text) 6 | import Data.IntMap (IntMap) 7 | import qualified Data.IntMap as IM 8 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 9 | import Data.Aeson.TH (deriveJSON, defaultOptions) 10 | 11 | -- A simple database of `Person` 12 | data Person = Person 13 | { name :: Text 14 | , age :: Int 15 | } 16 | $(deriveJSON defaultOptions ''Person) 17 | 18 | -- The Master Route 19 | data PeopleDB = PeopleDB 20 | { peopleRef :: IORef (IntMap Person) } 21 | 22 | -- Create an initial master route instance 23 | -- Initially our DB is empty 24 | initPeopleDB :: IO PeopleDB 25 | initPeopleDB = do 26 | ref <- newIORef $ IM.singleton 0 $ Person "Anon" 20 27 | return $ PeopleDB ref 28 | 29 | -- Create a new person 30 | newPerson :: Person -> PeopleDB -> IO Int 31 | newPerson v (PeopleDB ref) = do 32 | peeps <- readIORef ref 33 | let k = nextKey peeps 34 | writeIORef ref $ IM.insert k v peeps 35 | return k 36 | where 37 | nextKey peeps 38 | | IM.null peeps = 0 39 | | otherwise = fst (IM.findMax peeps) + 1 40 | 41 | -- Get data for a specifc person 42 | getPerson :: Int -> PeopleDB -> IO (Maybe Person) 43 | getPerson i (PeopleDB ref) = do 44 | peeps <- readIORef ref 45 | return $ IM.lookup i peeps 46 | 47 | -- Update a person 48 | -- Silently ignores if person isn't already in the DB 49 | updatePerson :: Int -> Person -> PeopleDB -> IO () 50 | updatePerson i p (PeopleDB ref) = do 51 | peeps <- readIORef ref 52 | writeIORef ref $ IM.update (const $ Just p) i peeps 53 | 54 | -- Delete a person 55 | -- Silently ignores if person isn't already in the DB 56 | deletePerson :: Int -> PeopleDB -> IO () 57 | deletePerson i (PeopleDB ref) = do 58 | peeps <- readIORef ref 59 | writeIORef ref $ IM.delete i peeps 60 | -------------------------------------------------------------------------------- /src/Routes/TH/ParseRoute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Routes.TH.ParseRoute 3 | ( -- ** ParseRoute 4 | mkParseRouteInstance 5 | ) where 6 | 7 | import Routes.TH.Types 8 | import Language.Haskell.TH.Syntax 9 | import Data.Text (Text) 10 | import Routes.Class 11 | import Routes.TH.Dispatch 12 | 13 | mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec 14 | mkParseRouteInstance cxt typ ress = do 15 | cls <- mkDispatchClause 16 | MkDispatchSettings 17 | { mdsRunHandler = [|\_ _ x _ -> x|] 18 | , mds404 = [|error "mds404"|] 19 | , mds405 = [|error "mds405"|] 20 | , mdsGetPathInfo = [|fst|] 21 | , mdsMethod = [|error "mdsMethod"|] 22 | , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] 23 | , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] 24 | , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] 25 | , mdsUnwrapper = return 26 | } 27 | (map removeMethods ress) 28 | helper <- newName "helper" 29 | fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] 30 | return $ instanceD cxt (ConT ''ParseRoute `AppT` typ) 31 | [ FunD 'parseRoute $ return $ Clause 32 | [] 33 | (NormalB $ fixer `AppE` VarE helper) 34 | [FunD helper [cls]] 35 | ] 36 | where 37 | -- We do this in order to ski the unnecessary method parsing 38 | removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res 39 | removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z 40 | 41 | removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res } 42 | 43 | fixDispatch (Methods x _) = Methods x [] 44 | fixDispatch x = x 45 | 46 | instanceD :: Cxt -> Type -> [Dec] -> Dec 47 | instanceD = InstanceD Nothing 48 | -------------------------------------------------------------------------------- /examples/subsites/src/HelloSub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, FlexibleInstances, MultiParamTypeClasses #-} 2 | module HelloSub where 3 | {- 4 | A simple subsite 5 | -} 6 | 7 | import Wai.Routes 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | 11 | -- The Subsite argument 12 | data HelloSubRoute = HelloSubRoute {getHello :: Text} 13 | 14 | -- The contract with the master site 15 | -- The master site should - 16 | -- 1. Have renderable routes (RenderRoute constraint) 17 | -- 2. Allow access to a parent route to go back to (parentRoute) 18 | -- 3. Allow access to the current user name (currentUserName) 19 | class RenderRoute master => HelloMaster master where 20 | parentRoute :: master -> Route master 21 | currentUserName :: master -> Text 22 | 23 | -- Generate routing code using mkRouteSub 24 | -- Note that for subsites, you also need to provide the constraint class 25 | -- (in this case `HelloMaster`), which provides the contract with the master site 26 | mkRouteSub "HelloSubRoute" "HelloMaster" [parseRoutes| 27 | / HomeR GET 28 | /foo FooR GET 29 | |] 30 | 31 | 32 | -- Subsite Handlers 33 | -- For subsites use HandlerS instead of Handler 34 | 35 | -- Hello 36 | getHomeR :: HelloMaster master => HandlerS HelloSubRoute master 37 | getHomeR = runHandlerM $ do 38 | m <- master 39 | s <- sub 40 | showRouteS <- showRouteSub 41 | html $ T.concat 42 | [ "<h1>" 43 | , getHello s 44 | , currentUserName m 45 | , "</h1>" 46 | , "<a href=\"" 47 | , showRouteS FooR 48 | , "\">Go to an internal subsite route - Foo</a>" 49 | , "<br />" 50 | , "<a href=\"" 51 | , showRoute $ parentRoute m 52 | , "\">Go back to the Master site /</a>" 53 | ] 54 | 55 | -- Foo 56 | getFooR :: HelloMaster master => HandlerS HelloSubRoute master 57 | getFooR = runHandlerM $ do 58 | showRouteS <- showRouteSub 59 | html $ T.concat 60 | ["<h1>FOOO</h1>" 61 | , "<a href=\"" 62 | , showRouteS HomeR 63 | , "\">Go back</a>" 64 | ] 65 | -------------------------------------------------------------------------------- /examples/blaze-html/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 3 | module Main where 4 | {- 5 | Simple demonstration of using blaze-html to generate html 6 | -} 7 | 8 | import Wai.Routes 9 | import Network.Wai.Application.Static 10 | import Data.Text (Text) 11 | import qualified Data.Text.Lazy as TL 12 | import Network.Wai.Handler.Warp (run) 13 | 14 | import Text.Blaze.Html.Renderer.Text (renderHtml) 15 | import qualified Text.Blaze.Html5 as H 16 | import Text.Blaze.Html5 ( Html, toMarkup) 17 | 18 | -- Data for a person 19 | data Person = Person 20 | { name :: Text 21 | , age :: Int 22 | } 23 | 24 | -- Our master datatype 25 | data MyApp = MyApp [Person] 26 | 27 | -- Initial DB 28 | defaultDB :: MyApp 29 | defaultDB = MyApp [Person "Bob" 12, Person "Mike" 11] 30 | 31 | -- Generate routes 32 | mkRoute "MyApp" [parseRoutes| 33 | / ListR GET 34 | |] 35 | 36 | getListR :: Handler MyApp 37 | getListR = runHandlerM $ do 38 | MyApp people <- sub 39 | let pageTitle = "Hello BlazeHtml" 40 | -- Render a page with a list of people 41 | html $ TL.toStrict $ page pageTitle $ peopleFragment people 42 | 43 | -- Render some HTML inside a full page 44 | page :: TL.Text -> Html -> TL.Text 45 | page titleText bodyHtml = renderHtml $ H.html $ do 46 | H.head $ H.title $ toMarkup titleText 47 | H.body $ do 48 | H.h1 $ toMarkup titleText 49 | bodyHtml 50 | 51 | -- Renders a list of people as HTML 52 | peopleFragment :: [Person] -> Html 53 | peopleFragment [] = H.h3 "No people found" 54 | peopleFragment fs = H.ol $ mapM_ personFragment fs 55 | 56 | -- Renders a Person as HTML 57 | personFragment :: Person -> Html 58 | personFragment (Person{..}) = H.li $ do 59 | H.p $ toMarkup $ "Name: " ++ show name 60 | H.p $ toMarkup $ "Age: " ++ show age 61 | 62 | -- Define Application using RouteM Monad 63 | -- The application that uses our route 64 | -- NOTE: We use the Route Monad to simplify routing 65 | application :: RouteM () 66 | application = do 67 | middleware logStdoutDev 68 | route defaultDB 69 | catchall $ staticApp $ defaultFileServerSettings "static" 70 | 71 | -- Run the application 72 | main :: IO () 73 | main = do 74 | putStrLn "Starting server on port 8080" 75 | run 8080 (waiApp application) 76 | -------------------------------------------------------------------------------- /examples/shakespeare/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | {- 5 | Example using shakespearean templates (hamlet, cassius, lucius, julius) 6 | -} 7 | 8 | import Wai.Routes 9 | import Data.Text (Text) 10 | import qualified Data.Text.Lazy as TL 11 | import Network.Wai.Handler.Warp (run) 12 | import Network.Wai.Application.Static 13 | 14 | import Text.Hamlet (hamletFile, hamlet, HtmlUrl) 15 | import Text.Blaze.Html.Renderer.Text (renderHtml) 16 | import Text.Cassius (renderCss, cassius, CssUrl) 17 | 18 | -- Data for a person 19 | data Person = Person 20 | { name :: Text 21 | , age :: Int 22 | } 23 | 24 | -- Our master datatype 25 | data MyApp = MyApp [Person] 26 | 27 | -- The 'Route' type represents the type of the typesafe Routes generated by wai-routes 28 | -- 'Route MyApp' means the 'Route' type generated for the master datatype 'MyApp' 29 | -- We alias it to 'MyAppRoute' for convenience 30 | type MyAppRoute = Route MyApp 31 | 32 | -- Initial DB 33 | defaultDB :: MyApp 34 | defaultDB = MyApp [Person "Bob" 12, Person "Mike" 11] 35 | 36 | -- Generate routes 37 | mkRoute "MyApp" [parseRoutes| 38 | / HomeR GET 39 | /style.css StylesheetR GET 40 | |] 41 | 42 | getHomeR :: Handler MyApp 43 | getHomeR = runHandlerM $ do 44 | MyApp people <- sub 45 | let pageTitle = "Hello Hamlet" 46 | html $ TL.toStrict $ renderHtml $ home pageTitle people showRouteQuery 47 | 48 | getStylesheetR :: Handler MyApp 49 | getStylesheetR = runHandlerM $ css $ TL.toStrict $ renderCss $ style showRouteQuery 50 | 51 | -- Inline cassius example, julius and lucius would be similar 52 | style :: CssUrl MyAppRoute 53 | style = [cassius| 54 | .page-title 55 | border: 1px solid red 56 | background: gray 57 | color: blue 58 | |] 59 | 60 | -- External hamlet example 61 | home :: Text -> [Person] -> HtmlUrl MyAppRoute 62 | home pageTitle people = $(hamletFile "templates/home.hamlet") 63 | 64 | -- Inline hamlet example 65 | copyright :: HtmlUrl MyAppRoute 66 | copyright = [hamlet| <small>Copyright 2015. All Rights Reserved |] 67 | 68 | -- Define Application using RouteM Monad 69 | application :: RouteM () 70 | application = do 71 | middleware logStdoutDev 72 | route defaultDB 73 | catchall $ staticApp $ defaultFileServerSettings "static" 74 | 75 | -- Run the application 76 | main :: IO () 77 | main = do 78 | putStrLn "Starting server on port 8080" 79 | run 8080 (waiApp application) 80 | -------------------------------------------------------------------------------- /examples/unrouted/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | {- 3 | A demonstration of using only "unrouted" handlers, without any TH 4 | 5 | Requires no GHC extensions 6 | Requires no Template Haskell or quasiquotes 7 | Cannot have a Master Site argument 8 | Requires no Routing code 9 | 10 | To see a more complex example of mixing unrouted and routed handlers, see hello-world-example 11 | -} 12 | 13 | import Data.IORef 14 | import Control.Monad.IO.Class (liftIO) 15 | import qualified Data.Text as T 16 | import qualified Data.Vault.Lazy as V 17 | 18 | import Wai.Routes 19 | import Network.Wai.Handler.Warp 20 | 21 | -- Run the application 22 | main :: IO () 23 | main = do 24 | -- Global state 25 | times <- liftIO $ newIORef (0::Int) 26 | 27 | -- We create a global vault key to store the counter 28 | -- This key is only created once when the application starts 29 | timesKey <- liftIO $ V.newKey 30 | 31 | -- Run the app 32 | putStrLn "Starting server on port 8080" 33 | run 8080 $ waiApp $ do 34 | 35 | -- Handlers (like routes) are cascaded 36 | 37 | -- The first handler is always called and can also be used to perform common 38 | -- global processing (such as incrementing the counter on every request) 39 | handler $ runHandlerM $ do 40 | -- Increment the global counter 41 | n <- liftIO $ readIORef times 42 | liftIO $ writeIORef times (n+1) 43 | -- Insert the key in the vault for all subsequent handlers to access 44 | updateVault $ V.insert timesKey n 45 | -- Remember to call finally next, so other handlers are invoked 46 | next 47 | 48 | -- Full handler functionality is available 49 | handler $ runHandlerM $ do 50 | -- You can access untyped (but parsed) route information 51 | Just (DefaultRoute (pieces, query)) <- maybeRoute 52 | Just n <- lookupVault timesKey 53 | if mod n 10 == 0 54 | -- Every 10th invocation, jump to the next handler 55 | then next 56 | else do 57 | html $ T.concat $ map T.pack $ 58 | [ "<h1>Hello! You have been here ", show n, " times</h1>" 59 | , "<p>Raw route path pieces - ", show pieces, "</p>" 60 | , "<p>Raw route query - ", show query, "</p>" 61 | ] 62 | 63 | -- This handler will only be reached when the previous handler calls next (on every 10th invocation) 64 | handler $ runHandlerM $ do 65 | Just n <- lookupVault timesKey 66 | html $ T.concat $ map T.pack ["<h1>You are the special ", show n, "th caller!</h1>"] 67 | -------------------------------------------------------------------------------- /examples/bare-wai/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns, RankNTypes #-} 2 | module Main where 3 | {- 4 | Using typesafe URLs with bare wai handlers 5 | -} 6 | 7 | import Network.Wai (responseLBS) 8 | 9 | import Wai.Routes 10 | import Network.Wai.Handler.Warp 11 | import Network.Wai.Application.Static 12 | import qualified Data.ByteString.Lazy as BS 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Encoding as E 16 | 17 | -- The Master Site argument 18 | data MyRoute = MyRoute 19 | 20 | -- Generate routing code 21 | mkRoute "MyRoute" [parseRoutes| 22 | / HomeR GET 23 | /hello/#Text HelloR GET 24 | |] 25 | 26 | -- Handlers 27 | 28 | -- Bare handlers don't use `runHandlerM` 29 | -- Get env and request data as arguments 30 | getHomeR :: Handler MyRoute 31 | getHomeR _env req continue = do 32 | -- We are in the IO Monad 33 | putStrLn "Home Page" 34 | -- Construct a wai Response and pass it to the continuation function 35 | continue resp 36 | where 37 | showRouteBS = textToBytestring . showRoute 38 | Just thisRoute = currentRoute req 39 | resp = responseLBS 40 | status200 41 | [("Content-Type", "text/html")] 42 | (BS.concat 43 | [ "<h1>Home</h1>" 44 | , "<p>You are on route - ", showRouteBS thisRoute, "</p>" 45 | , "<p>" 46 | , "<a href=\"", showRouteBS (HelloR "World"), "\">Go to hello</a>" 47 | , " to be greeted!" 48 | , "</p>" 49 | ]) 50 | 51 | -- Hello 52 | -- "who" Text parameter is passed to the handler as usual 53 | getHelloR :: Text -> Handler MyRoute 54 | getHelloR who _env _req continue = do 55 | putStrLn $ "Hello " ++ T.unpack who 56 | continue resp 57 | where 58 | showRouteBS = textToBytestring . showRoute 59 | resp = responseLBS 60 | status200 61 | [("Content-Type", "text/html")] 62 | (BS.concat 63 | [ "<h1>Hello ", textToBytestring who, "!</h1>" 64 | , "<a href=\"", showRouteBS HomeR, "\">Go back</a>" 65 | ]) 66 | 67 | -- The application that uses our route 68 | application :: RouteM () 69 | application = do 70 | middleware logStdoutDev 71 | route MyRoute 72 | catchall $ staticApp $ defaultFileServerSettings "static" 73 | 74 | -- Run the application 75 | main :: IO () 76 | main = do 77 | putStrLn "Starting server on port 8080" 78 | run 8080 $ waiApp application 79 | 80 | -- PRIVATE UTILITY 81 | textToBytestring :: Text -> BS.ByteString 82 | textToBytestring = BS.fromStrict . E.encodeUtf8 83 | -------------------------------------------------------------------------------- /src/Routes/ContentTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TypeFamilies #-} 2 | 3 | {- | 4 | Module : Routes.ContentTypes 5 | Copyright : (c) Anupam Jain 2013 6 | License : MIT (see the file LICENSE) 7 | 8 | Maintainer : ajnsit@gmail.com 9 | Stability : experimental 10 | Portability : non-portable (uses ghc extensions) 11 | 12 | Defines the commonly used content types 13 | -} 14 | module Routes.ContentTypes 15 | ( -- * Construct content Type 16 | acceptContentType 17 | , contentType, contentTypeFromFile 18 | -- * Various common content types 19 | , typeAll 20 | , typeHtml, typePlain, typeJson 21 | , typeXml, typeAtom, typeRss 22 | , typeJpeg, typePng, typeGif 23 | , typeSvg, typeJavascript, typeCss 24 | , typeFlv, typeOgv, typeOctet 25 | ) 26 | where 27 | 28 | import qualified Data.Text as T (pack) 29 | import Data.ByteString (ByteString) 30 | import Data.ByteString.Char8 () -- Import IsString instance for ByteString 31 | import Network.HTTP.Types.Header (HeaderName()) 32 | import Network.Mime (defaultMimeLookup) 33 | import System.FilePath (takeFileName) 34 | 35 | -- | The request header for accpetable content types 36 | acceptContentType :: HeaderName 37 | acceptContentType = "Accept" 38 | 39 | -- | Construct an appropriate content type header from a file name 40 | contentTypeFromFile :: FilePath -> ByteString 41 | contentTypeFromFile = defaultMimeLookup . T.pack . takeFileName 42 | 43 | -- | Creates a content type header 44 | -- Ready to be passed to `responseLBS` 45 | contentType :: HeaderName 46 | contentType = "Content-Type" 47 | 48 | typeAll :: ByteString 49 | typeAll = "*/*" 50 | 51 | typeHtml :: ByteString 52 | typeHtml = "text/html; charset=utf-8" 53 | 54 | typePlain :: ByteString 55 | typePlain = "text/plain; charset=utf-8" 56 | 57 | typeJson :: ByteString 58 | typeJson = "application/json; charset=utf-8" 59 | 60 | typeXml :: ByteString 61 | typeXml = "text/xml" 62 | 63 | typeAtom :: ByteString 64 | typeAtom = "application/atom+xml" 65 | 66 | typeRss :: ByteString 67 | typeRss = "application/rss+xml" 68 | 69 | typeJpeg :: ByteString 70 | typeJpeg = "image/jpeg" 71 | 72 | typePng :: ByteString 73 | typePng = "image/png" 74 | 75 | typeGif :: ByteString 76 | typeGif = "image/gif" 77 | 78 | typeSvg :: ByteString 79 | typeSvg = "image/svg+xml" 80 | 81 | typeJavascript :: ByteString 82 | typeJavascript = "text/javascript; charset=utf-8" 83 | 84 | typeCss :: ByteString 85 | typeCss = "text/css; charset=utf-8" 86 | 87 | typeFlv :: ByteString 88 | typeFlv = "video/x-flv" 89 | 90 | typeOgv :: ByteString 91 | typeOgv = "video/ogg" 92 | 93 | typeOctet :: ByteString 94 | typeOctet = "application/octet-stream" 95 | -------------------------------------------------------------------------------- /src/Routes/TH/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | -- | Warning! This module is considered internal and may have breaking changes 4 | module Routes.TH.Types 5 | ( -- * Data types 6 | Resource (..) 7 | , ResourceTree (..) 8 | , Piece (..) 9 | , Dispatch (..) 10 | , CheckOverlap 11 | , FlatResource (..) 12 | -- ** Helper functions 13 | , resourceMulti 14 | , resourceTreePieces 15 | , resourceTreeName 16 | , flatten 17 | ) where 18 | 19 | import Language.Haskell.TH.Syntax 20 | 21 | data ResourceTree typ 22 | = ResourceLeaf (Resource typ) 23 | | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] 24 | deriving (Lift, Show, Functor) 25 | 26 | resourceTreePieces :: ResourceTree typ -> [Piece typ] 27 | resourceTreePieces (ResourceLeaf r) = resourcePieces r 28 | resourceTreePieces (ResourceParent _ _ x _) = x 29 | 30 | resourceTreeName :: ResourceTree typ -> String 31 | resourceTreeName (ResourceLeaf r) = resourceName r 32 | resourceTreeName (ResourceParent x _ _ _) = x 33 | 34 | data Resource typ = Resource 35 | { resourceName :: String 36 | , resourcePieces :: [Piece typ] 37 | , resourceDispatch :: Dispatch typ 38 | , resourceAttrs :: [String] 39 | , resourceCheck :: CheckOverlap 40 | } 41 | deriving (Lift, Show, Functor) 42 | 43 | type CheckOverlap = Bool 44 | 45 | data Piece typ = Static String | Dynamic typ 46 | deriving (Lift, Show) 47 | 48 | instance Functor Piece where 49 | fmap _ (Static s) = Static s 50 | fmap f (Dynamic t) = Dynamic (f t) 51 | 52 | data Dispatch typ = 53 | Methods 54 | { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end 55 | , methodsMethods :: [String] -- ^ supported request methods 56 | } 57 | | Subsite 58 | { subsiteType :: typ 59 | , subsiteFunc :: String 60 | } 61 | deriving (Lift, Show) 62 | 63 | instance Functor Dispatch where 64 | fmap f (Methods a b) = Methods (fmap f a) b 65 | fmap f (Subsite a b) = Subsite (f a) b 66 | 67 | resourceMulti :: Resource typ -> Maybe typ 68 | resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t 69 | resourceMulti _ = Nothing 70 | 71 | data FlatResource a = FlatResource 72 | { frParentPieces :: [(String, [Piece a])] 73 | , frName :: String 74 | , frPieces :: [Piece a] 75 | , frDispatch :: Dispatch a 76 | , frCheck :: Bool 77 | } deriving (Show) 78 | 79 | flatten :: [ResourceTree a] -> [FlatResource a] 80 | flatten = 81 | concatMap (go id True) 82 | where 83 | go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] 84 | go front check' (ResourceParent name check pieces children) = 85 | concatMap (go (front . ((name, pieces):)) (check && check')) children 86 | -------------------------------------------------------------------------------- /src/Routes/Overlap.hs: -------------------------------------------------------------------------------- 1 | -- | Check for overlapping routes. 2 | module Routes.Overlap 3 | ( findOverlapNames 4 | , Overlap (..) 5 | ) where 6 | 7 | import Routes.TH.Types 8 | import Data.List (intercalate) 9 | 10 | data Flattened t = Flattened 11 | { fNames :: [String] 12 | , fPieces :: [Piece t] 13 | , fHasSuffix :: Bool 14 | , fCheck :: CheckOverlap 15 | } 16 | 17 | flatten :: ResourceTree t -> [Flattened t] 18 | flatten = 19 | go id id True 20 | where 21 | go names pieces check (ResourceLeaf r) = return Flattened 22 | { fNames = names [resourceName r] 23 | , fPieces = pieces (resourcePieces r) 24 | , fHasSuffix = hasSuffix $ ResourceLeaf r 25 | , fCheck = check && resourceCheck r 26 | } 27 | go names pieces check (ResourceParent newname check' newpieces children) = 28 | concatMap (go names' pieces' (check && check')) children 29 | where 30 | names' = names . (newname:) 31 | pieces' = pieces . (newpieces ++) 32 | 33 | data Overlap t = Overlap 34 | { overlapParents :: [String] -> [String] -- ^ parent resource trees 35 | , overlap1 :: ResourceTree t 36 | , overlap2 :: ResourceTree t 37 | } 38 | 39 | data OverlapF = OverlapF 40 | { _overlapF1 :: [String] 41 | , _overlapF2 :: [String] 42 | } 43 | 44 | overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool 45 | 46 | -- No pieces on either side, will overlap regardless of suffix 47 | overlaps [] [] _ _ = True 48 | 49 | -- No pieces on the left, will overlap if the left side has a suffix 50 | overlaps [] _ suffixX _ = suffixX 51 | 52 | -- Ditto for the right 53 | overlaps _ [] _ suffixY = suffixY 54 | 55 | -- Compare the actual pieces 56 | overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY = 57 | piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY 58 | 59 | piecesOverlap :: Piece t -> Piece t -> Bool 60 | -- Statics only match if they equal. Dynamics match with anything 61 | piecesOverlap (Static x) (Static y) = x == y 62 | piecesOverlap _ _ = True 63 | 64 | findOverlapNames :: [ResourceTree t] -> [(String, String)] 65 | findOverlapNames = 66 | map go . findOverlapsF . filter fCheck . concatMap Routes.Overlap.flatten 67 | where 68 | go (OverlapF x y) = 69 | (go' x, go' y) 70 | where 71 | go' = intercalate "/" 72 | 73 | findOverlapsF :: [Flattened t] -> [OverlapF] 74 | findOverlapsF [] = [] 75 | findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs 76 | 77 | findOverlapF :: Flattened t -> Flattened t -> [OverlapF] 78 | findOverlapF x y 79 | | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)] 80 | | otherwise = [] 81 | 82 | hasSuffix :: ResourceTree t -> Bool 83 | hasSuffix (ResourceLeaf r) = 84 | case resourceDispatch r of 85 | Subsite{} -> True 86 | Methods Just{} _ -> True 87 | Methods Nothing _ -> False 88 | hasSuffix ResourceParent{} = True 89 | -------------------------------------------------------------------------------- /examples/subsites/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} 2 | module Main where 3 | {- 4 | Simple demonstration of subsites 5 | -} 6 | 7 | import Wai.Routes 8 | import Network.Wai.Handler.Warp 9 | import Network.Wai.Application.Static 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | 13 | -- Import HelloSub subsite 14 | import qualified HelloSub as Sub 15 | import HelloSub (HelloSubRoute(..), HelloMaster(..)) 16 | 17 | -- The Master Site argument 18 | data MyRoute = MyRoute 19 | 20 | -- Create a subsite datatype from the master datatype 21 | -- NOTE: The (Route master -> Route sub) conversion function handles the route arguments 22 | -- which are defined in the master routes and passed down to the subsite handlers via the subsite datatype 23 | -- So in this case, we handle the #Text greeting argument here and put it into the subsite datatype 24 | getHelloSubRoute :: MyRoute -> Text -> HelloSubRoute 25 | getHelloSubRoute _ greeting = HelloSubRoute $ T.append greeting " from subsite: " 26 | 27 | -- Like getHelloSubRoute, but uses a default greeting 28 | -- This shows an example of passing no route argument data to the subsite 29 | namasteHelloSubRoute :: MyRoute -> HelloSubRoute 30 | namasteHelloSubRoute mr = getHelloSubRoute mr "namaste" 31 | 32 | -- Generate routing code 33 | -- getHelloSubRoute is defined in HelloSub.hs 34 | -- Note that subsites are allowed within hierarchical routes as well 35 | mkRoute "MyRoute" [parseRoutes| 36 | / HomeR GET 37 | /hello/#Text HelloR HelloSubRoute getHelloSubRoute 38 | /sub SubR: 39 | /sub2 Sub2R: 40 | /hello HelloSubR HelloSubRoute namasteHelloSubRoute 41 | |] 42 | 43 | -- Fulfill the contract with HelloSub subsite 44 | instance HelloMaster MyRoute where 45 | currentUserName _ = "John Doe" 46 | parentRoute _ = HomeR 47 | 48 | -- Handlers 49 | 50 | -- Homepage 51 | getHomeR :: Handler MyRoute 52 | getHomeR = runHandlerM $ do 53 | Just r <- maybeRoute 54 | showRouteS <- showRouteSub 55 | html $ T.concat 56 | [ "<h1>Home</h1>" 57 | , "<p>You are on route - " 58 | , showRoute r 59 | , "</p>" 60 | , "<p>" 61 | , "<a href=\"" 62 | , showRouteS $ HelloR "howdy" Sub.HomeR 63 | , "\">Go to subsite 'howdy'</a>" 64 | , " or " 65 | , "<a href=\"" 66 | , showRouteS $ HelloR "namaste" Sub.HomeR 67 | , "\">to subsite 'namaste'</a>" 68 | , " or " 69 | , "<a href=\"" 70 | , showRouteS $ SubR $ Sub2R $ HelloSubR Sub.HomeR 71 | , "\">to deeply nested subsite with default 'namaste'</a>" 72 | , " to be greeted!" 73 | , "</p>" 74 | ] 75 | 76 | -- Run the application 77 | main :: IO () 78 | main = do 79 | putStrLn "Starting server on port 8080" 80 | run 8080 $ waiApp $ do 81 | -- Log everything 82 | middleware logStdoutDev 83 | -- Add our routing 84 | route MyRoute 85 | -- Serve static files when no route matches 86 | defaultAction $ staticApp $ defaultFileServerSettings "static" 87 | -------------------------------------------------------------------------------- /src/Routes/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-} 2 | 3 | {- | 4 | Module : Routes.Monad 5 | Copyright : (c) Anupam Jain 2013 6 | License : MIT (see the file LICENSE) 7 | 8 | Maintainer : ajnsit@gmail.com 9 | Stability : experimental 10 | Portability : non-portable (uses ghc extensions) 11 | 12 | Defines a Routing Monad that provides easy composition of Routes 13 | -} 14 | module Routes.Monad 15 | ( -- * Route Monad 16 | RouteM 17 | -- * Compose Routes 18 | , DefaultMaster(..) 19 | , Route(DefaultRoute) 20 | , handler 21 | , middleware 22 | , route 23 | , catchall 24 | , defaultAction 25 | -- * Convert to Wai Application 26 | , waiApp 27 | , toWaiApp 28 | ) 29 | where 30 | 31 | import Network.Wai 32 | import Routes.Routes 33 | import Routes.DefaultRoute 34 | import Network.HTTP.Types (status404) 35 | 36 | import Util.Free (F(..), liftF) 37 | 38 | -- A Router functor can either add a middleware, or resolve to an app itself. 39 | data RouterF x = M Middleware x | D Application deriving Functor 40 | 41 | -- Router type 42 | type RouteM = F RouterF 43 | 44 | -- | Catch all routes and process them with the supplied application. 45 | -- Note: As expected from the name, no request proceeds past a catchall. 46 | catchall :: Application -> RouteM () 47 | catchall a = liftF $ D a 48 | 49 | -- | Synonym of `catchall`. Kept for backwards compatibility 50 | defaultAction :: Application -> RouteM () 51 | defaultAction = catchall 52 | 53 | -- | Add a middleware to the application 54 | -- Middleware are ordered so the one declared earlier wraps the ones later 55 | middleware :: Middleware -> RouteM () 56 | middleware m = liftF $ M m () 57 | 58 | -- | Add a wai-routes handler 59 | handler :: HandlerS DefaultMaster DefaultMaster -> RouteM () 60 | handler h = middleware $ customRouteDispatch dispatcher' DefaultMaster 61 | where 62 | dispatcher' env req = runHandler h env (Just $ DefaultRoute $ getRoute req) req 63 | getRoute req = (pathInfo $ waiReq req, readQueryString $ queryString $ waiReq req) 64 | 65 | -- | Add a route to the application. 66 | -- Routes are ordered so the one declared earlier is matched first. 67 | route :: (Routable master master) => master -> RouteM () 68 | route = middleware . routeDispatch 69 | 70 | -- The final "catchall" application, simply returns a 404 response 71 | -- Ideally you should put your own default application 72 | defaultApplication :: Application 73 | defaultApplication _req h = h $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found" 74 | 75 | -- | Convert a RouteM monad into a wai application. 76 | -- Note: We ignore the return type of the monad 77 | waiApp :: RouteM () -> Application 78 | waiApp (F r) = r (const defaultApplication) f 79 | where 80 | f (M m r') = m r' 81 | f (D a) = a 82 | 83 | -- | Similar to waiApp but returns the app in an arbitrary monad 84 | -- Kept for backwards compatibility 85 | toWaiApp :: Monad m => RouteM () -> m Application 86 | toWaiApp = return . waiApp 87 | -------------------------------------------------------------------------------- /examples/kitchen/src/Main.hs: -------------------------------------------------------------------------------- 1 | -- These extensions are needed for wai-routes 2 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, ViewPatterns, TemplateHaskell, QuasiQuotes, RankNTypes #-} 3 | -- This extension is for convenience 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Main where 7 | {- 8 | Demonstrates all the major features of wai-routes (WIP) 9 | -} 10 | 11 | import Data.Maybe (fromMaybe) 12 | import Data.Monoid (mconcat) 13 | import Data.Text (Text) 14 | 15 | import Wai.Routes 16 | import Network.Wai.Handler.Warp (run) 17 | 18 | ------------- 19 | -- ROUTING -- 20 | ------------- 21 | 22 | -- The master route 23 | data MasterRoute = MasterRoute 24 | -- wai-routes uses compile time checks to avoid routes overlap 25 | -- We can use parseRoutesNoCheck, if we are certain we want overlapping routes 26 | mkRoute "MasterRoute" [parseRoutesNoCheck| 27 | / RootR GET POST DELETE PUT 28 | /read-headers ReadHeadersR POST 29 | /set-headers SetHeadersR POST 30 | /json JsonR GET 31 | /submit SubmitR POST 32 | /all AllR 33 | /#Text BeamR GET 34 | |] 35 | 36 | 37 | -------------- 38 | -- HANDLERS -- 39 | -------------- 40 | getRootR, deleteRootR, postRootR, putRootR :: Handler MasterRoute 41 | getRootR = runHandlerM $ plain "gotten!" 42 | deleteRootR = runHandlerM $ plain "deleted!" 43 | postRootR = runHandlerM $ plain "posted!" 44 | putRootR = runHandlerM $ plain "put-ted!" 45 | 46 | -- get a header: 47 | postReadHeadersR :: Handler MasterRoute 48 | postReadHeadersR = runHandlerM $ do 49 | agent <- reqHeader "User-Agent" 50 | plain $ fromMaybe "unknown user-agent" agent 51 | 52 | -- set a header: 53 | postSetHeadersR :: Handler MasterRoute 54 | postSetHeadersR = runHandlerM $ do 55 | status status302 56 | header "Location" "http://www.google.com.au" 57 | 58 | -- set content type 59 | getJsonR :: Handler MasterRoute 60 | getJsonR = runHandlerM $ json 61 | (Right ("hello", "world") :: Either Int (String, String)) -- you need types for JSON 62 | 63 | -- named parameters: 64 | getBeamR :: Text -> Handler MasterRoute 65 | getBeamR beam = runHandlerM $ html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>" ] 66 | 67 | -- unnamed parameters from a query string or a form: 68 | postSubmitR :: Handler MasterRoute 69 | postSubmitR = runHandlerM $ do 70 | name <- getParam "name" 71 | plain $ fromMaybe "unknown" name 72 | 73 | -- Match a route regardless of the method 74 | handleAllR :: Handler MasterRoute 75 | handleAllR = runHandlerM $ plain "matches all methods" 76 | 77 | ------------------------- 78 | -- RUN THE APPLICATION -- 79 | ------------------------- 80 | 81 | main :: IO () 82 | main = do 83 | putStrLn "Starting server on port 8080" 84 | -- Run the app on port 8080 85 | run 8080 $ waiApp $ do 86 | -- Log everything 87 | middleware logStdoutDev 88 | -- Match our routes 89 | route MasterRoute 90 | -- handler for when there is no matched route 91 | -- (this should be the last handler because it matches all routes) 92 | handler $ runHandlerM $ plain "there is no such route." 93 | 94 | 95 | -------------------------------------------------------------------------------- /wai-routes.cabal: -------------------------------------------------------------------------------- 1 | name : wai-routes 2 | version : 0.10.4 3 | cabal-version : 1.18 4 | build-type : Simple 5 | license : MIT 6 | license-file : LICENSE 7 | maintainer : ajnsit@gmail.com 8 | stability : Experimental 9 | homepage : https://ajnsit.github.io/wai-routes/ 10 | synopsis : Typesafe URLs for Wai applications. 11 | description : Provides easy to use typesafe URLs for Wai Applications. See README for more information. Also see examples/ directory for usage examples. 12 | category : Network 13 | author : Anupam Jain 14 | data-dir : "" 15 | extra-source-files : README.md 16 | 17 | source-repository head 18 | type : git 19 | location : http://github.com/ajnsit/wai-routes 20 | 21 | source-repository this 22 | type : git 23 | location : http://github.com/ajnsit/wai-routes/tree/v0.10.4 24 | tag : v0.10.4 25 | 26 | library 27 | build-depends : base 28 | , wai 29 | , wai-extra 30 | , text 31 | , template-haskell 32 | , mtl 33 | , aeson 34 | , containers 35 | , random 36 | , path-pieces 37 | , bytestring 38 | , http-types 39 | , blaze-builder 40 | , monad-loops 41 | , case-insensitive 42 | , mime-types 43 | , filepath 44 | , cookie 45 | , data-default-class 46 | , vault 47 | , safe-exceptions 48 | exposed-modules : Wai.Routes, Network.Wai.Middleware.Routes 49 | other-modules : Routes.Parse 50 | Routes.Overlap 51 | Routes.Class 52 | Routes.Routes 53 | Routes.Monad 54 | Routes.Handler 55 | Routes.ContentTypes 56 | Routes.DefaultRoute 57 | Routes.TH 58 | Routes.TH.Types 59 | Routes.TH.Dispatch 60 | Routes.TH.ParseRoute 61 | Routes.TH.RenderRoute 62 | Routes.TH.RouteAttrs 63 | Util.Free 64 | exposed : True 65 | buildable : True 66 | hs-source-dirs : src 67 | default-language : Haskell2010 68 | ghc-options : -Wall 69 | 70 | test-suite test 71 | main-is : Spec.hs 72 | other-modules : HelloSpec 73 | type : exitcode-stdio-1.0 74 | default-language : Haskell2010 75 | hs-source-dirs : test 76 | GHC-options : -Wall -threaded -fno-warn-orphans 77 | 78 | build-depends : base 79 | , wai 80 | , aeson 81 | , hspec 82 | , hspec-wai 83 | , hspec-wai-json 84 | , text 85 | , wai-routes 86 | ghc-options : -Wall 87 | -------------------------------------------------------------------------------- /examples/hello-world/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} 2 | module Main where 3 | {- 4 | Simple demonstration of building routes 5 | Note: Look at the code in subsites/ for an example of building the same functionality as a subsite. 6 | -} 7 | 8 | import Wai.Routes 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Application.Static 11 | import qualified Data.Text as T 12 | import Data.Maybe (fromMaybe) 13 | 14 | -- The Master Site argument 15 | data MyRoute = MyRoute 16 | 17 | -- Generate routing code 18 | mkRoute "MyRoute" [parseRoutes| 19 | / HomeR GET 20 | /hello HelloR GET 21 | /post PostR POST 22 | /upper UpperR: 23 | / UpperBasementR GET 24 | /lower LowerR: 25 | / LowerBasementR GET 26 | |] 27 | 28 | -- Handlers 29 | 30 | -- Homepage 31 | getHomeR :: Handler MyRoute 32 | getHomeR = runHandlerM $ do 33 | Just r <- maybeRoute 34 | html $ T.concat 35 | [ "<h1>Home</h1>" 36 | , "<p>You are on route - ", showRoute r, "</p>" 37 | , "<p>" 38 | , "<a href=\"", showRoute HelloR, "\">Go to hello</a>" 39 | , " to be greeted!" 40 | , "</p>" 41 | , "<p>" 42 | , "<a href=\"", showRoute (UpperR UpperBasementR), "\">Explore the basement</a>" 43 | , "</p>" 44 | ] 45 | 46 | -- Hello 47 | getHelloR :: Handler MyRoute 48 | getHelloR = runHandlerM $ do 49 | html $ T.concat 50 | [ "<h1>Hello World!</h1>" 51 | , "<a href=\"", showRoute HomeR, "\">Go back</a>" 52 | ] 53 | 54 | -- Post parameters (getParam can also be used for query params) 55 | postPostR :: Handler MyRoute 56 | postPostR = runHandlerM $ do 57 | name' <- getParam "name" 58 | let name = fromMaybe "unnamed" name' 59 | html $ T.concat 60 | [ "<h1>Hello '", name, "'!</h1>" 61 | , "<a href=\"", showRoute HomeR, "\">Go back</a>" 62 | ] 63 | 64 | -- Nested hierarchical routes 65 | getUpperBasementR :: Handler MyRoute 66 | getUpperBasementR = runHandlerM $ do 67 | html $ T.concat 68 | [ "<h1>You are at the upper basement!</h1>" 69 | , "<p>" 70 | , "<a href=\"", showRoute HomeR, "\">Go back up</a>" 71 | , "</p>" 72 | , "<p>" 73 | , "<a href=\"", showRoute (UpperR $ LowerR LowerBasementR), "\">Take the stairs down</a>" 74 | , "</p>" 75 | ] 76 | 77 | getLowerBasementR :: Handler MyRoute 78 | getLowerBasementR = runHandlerM $ do 79 | html $ T.concat 80 | [ "<h1>You found the lower basement!</h1>" 81 | , "<a href=\"", showRoute (UpperR UpperBasementR), "\">Take the stairs up</a>" 82 | ] 83 | 84 | -- An example of an unrouted handler 85 | handleInfoRequest :: Handler DefaultMaster 86 | handleInfoRequest = runHandlerM $ do 87 | Just (DefaultRoute (_,query)) <- maybeRoute 88 | case lookup "info" query of 89 | -- If an override param "info" was supplied then display info 90 | Just _ -> plain "Wai-routes, hello world example, handleInfoRequest" 91 | -- Else, move on to the next handler (i.e. do nothing special) 92 | Nothing -> next 93 | 94 | -- The application that uses our route 95 | -- NOTE: We use the Route Monad to simplify routing 96 | application :: RouteM () 97 | application = do 98 | middleware logStdoutDev 99 | handler handleInfoRequest 100 | route MyRoute 101 | catchall $ staticApp $ defaultFileServerSettings "static" 102 | 103 | -- Run the application 104 | main :: IO () 105 | main = do 106 | putStrLn "Starting server on port 8080" 107 | run 8080 $ waiApp application 108 | -------------------------------------------------------------------------------- /examples/rest-json/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, RankNTypes #-} 2 | module Main where 3 | {- 4 | Demonstrates use of Aeson to create a simple JSON REST API 5 | Note: This example doesn't persist data. And is also not threadsafe. 6 | Use a more robust data storage mechanism in production! 7 | An example of doing this with something like Persistent is in the works. 8 | 9 | Note: Compiling this will give some orphan instances warning 10 | as PeopleRoute is defined in another file. This can't be helped. 11 | -} 12 | 13 | import Wai.Routes 14 | import Network.Wai.Handler.Warp (run) 15 | import Network.Wai.Application.Static 16 | import Data.Aeson.TH (deriveJSON, defaultOptions) 17 | import Data.IORef (readIORef) 18 | import Control.Monad.IO.Class (liftIO) 19 | 20 | -- Import the CRUD operations for our DB 21 | import PersonCrud (initPeopleDB, PeopleDB(..), newPerson, getPerson, updatePerson, deletePerson) 22 | 23 | 24 | -------------------- 25 | -- RESPONSE TYPES -- 26 | -------------------- 27 | 28 | newtype Err = Err { error:: String } 29 | $(deriveJSON defaultOptions ''Err) 30 | 31 | newtype PersonId = PersonId { personId :: Int } 32 | $(deriveJSON defaultOptions ''PersonId) 33 | 34 | data OK = OK 35 | $(deriveJSON defaultOptions ''OK) 36 | 37 | ------------- 38 | -- ROUTING -- 39 | ------------- 40 | 41 | data PeopleRoute = PeopleRoute PeopleDB 42 | 43 | -- Generate routing code 44 | -- GET /people -> Gets the list of people 45 | -- POST /people -> Creates a new person 46 | -- GET /person/#id -> Gets a person's details 47 | -- POST /person/#id -> Change a person's details 48 | -- DELETE /person/#id -> Delete a person 49 | mkRoute "PeopleRoute" [parseRoutes| 50 | / PeopleR GET POST 51 | /person/#Int PersonR GET POST DELETE 52 | |] 53 | 54 | 55 | ------------------------- 56 | -- RUN THE APPLICATION -- 57 | ------------------------- 58 | 59 | main :: IO () 60 | main = do 61 | -- Initialise people db 62 | db <- initPeopleDB 63 | putStrLn "Starting server on port 8080" 64 | run 8080 $ waiApp $ application $ PeopleRoute db 65 | 66 | -- Compose our application with routing 67 | application :: PeopleRoute -> RouteM () 68 | application r = do 69 | middleware logStdoutDev 70 | route r 71 | catchall $ staticApp $ defaultFileServerSettings "static" 72 | 73 | 74 | -------------- 75 | -- HANDLERS -- 76 | -------------- 77 | 78 | -- Get all people 79 | getPeopleR :: Handler PeopleRoute 80 | getPeopleR = runHandlerM $ do 81 | PeopleRoute (PeopleDB ref) <- sub 82 | peeps <- liftIO $ readIORef ref 83 | json peeps 84 | 85 | -- Create a new person 86 | postPeopleR :: Handler PeopleRoute 87 | postPeopleR = runHandlerM $ do 88 | p <- jsonBody 89 | case p of 90 | Left s -> do 91 | status status400 92 | json $ Err s 93 | Right p' -> do 94 | i <- runCrudAction $ newPerson p' 95 | json $ PersonId i 96 | 97 | -- Get a person's data 98 | getPersonR :: Int -> Handler PeopleRoute 99 | getPersonR i = runHandlerM $ do 100 | p <- runCrudAction $ getPerson i 101 | case p of 102 | Nothing -> do 103 | status status404 104 | json $ Err "No such person" 105 | Just p' -> json p' 106 | 107 | -- Update a person's data 108 | postPersonR :: Int -> Handler PeopleRoute 109 | postPersonR i = runHandlerM $ do 110 | p <- jsonBody 111 | case p of 112 | Left s -> do 113 | status status400 114 | json $ Err s 115 | Right p' -> do 116 | runCrudAction $ updatePerson i p' 117 | json OK 118 | 119 | -- Delete a person 120 | deletePersonR :: Int -> Handler PeopleRoute 121 | deletePersonR i = runHandlerM $ do 122 | runCrudAction $ deletePerson i 123 | json OK 124 | 125 | 126 | ------------- 127 | -- UTILITY -- 128 | ------------- 129 | 130 | -- Run an IO action with PeopleRoute 131 | runCrudAction :: (PeopleDB -> IO a) -> HandlerM PeopleRoute master a 132 | runCrudAction f = do 133 | PeopleRoute peopleDB <- sub 134 | liftIO $ f peopleDB 135 | -------------------------------------------------------------------------------- /src/Wai/Routes.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Wai.Routes 3 | Copyright : (c) Anupam Jain 2013 4 | License : MIT (see the file LICENSE) 5 | 6 | Maintainer : ajnsit@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (uses ghc extensions) 9 | 10 | This package provides typesafe URLs for Wai applications. 11 | -} 12 | module Wai.Routes 13 | ( -- * Declaring Routes using Template Haskell 14 | parseRoutes 15 | , parseRoutesFile -- | Parse routes declared in a file 16 | , parseRoutesNoCheck 17 | , parseRoutesFileNoCheck -- | Same as parseRoutesFile, but performs no overlap checking. 18 | 19 | , mkRoute 20 | , mkRouteSub 21 | 22 | -- * Dispatch 23 | , routeDispatch 24 | 25 | -- * URL rendering and parsing 26 | , showRoute 27 | , showRouteQuery 28 | , readRoute 29 | , showRouteMaster 30 | , showRouteQueryMaster 31 | , readRouteMaster 32 | , showRouteSub 33 | , showRouteQuerySub 34 | , readRouteSub 35 | 36 | -- * Application Handlers 37 | , Handler 38 | , HandlerS 39 | 40 | -- * Generated Datatypes 41 | , Routable(..) -- | Used internally. However needs to be exported for TH to work. 42 | , RenderRoute(..) -- | A `RenderRoute` instance for your site datatype is automatically generated by `mkRoute` 43 | , ParseRoute(..) -- | A `ParseRoute` instance for your site datatype is automatically generated by `mkRoute` 44 | , RouteAttrs(..) -- | A `RouteAttrs` instance for your site datatype is automatically generated by `mkRoute` 45 | 46 | -- * Accessing Raw Request Data 47 | , RequestData -- | An abstract representation of the request data. You can get the wai request object by using `waiReq` 48 | , waiReq -- | Extract the wai `Request` object from `RequestData` 49 | , nextApp -- | Extract the next Application in the stack 50 | , runNext -- | Run the next application in the stack 51 | 52 | -- * Route Monad makes it easy to compose routes together 53 | , RouteM 54 | , DefaultMaster(..) 55 | , Route(DefaultRoute) 56 | , handler -- | Add a wai-routes handler 57 | , catchall -- | Catch all routes with the supplied application 58 | , defaultAction -- | A synonym for `catchall`, kept for backwards compatibility 59 | , middleware -- | Add another middleware to the app 60 | , route -- | Add another routed middleware to the app 61 | , waiApp -- | Convert a RouteM to a wai Application 62 | , toWaiApp -- | Similar to waiApp, but result is wrapped in a monad. Kept for backwards compatibility 63 | 64 | -- * HandlerM Monad makes it easy to build a handler 65 | , HandlerM() 66 | , runHandlerM -- | Run a HandlerM to get a Handler 67 | , mountedAppHandler -- | Convert a full wai application to a HandlerS 68 | , request -- | Access the request data 69 | , isWebsocket -- | Is this a websocket request 70 | , reqHeader -- | Get a particular request header (case insensitive) 71 | , reqHeaders -- | Get all request headers (case insensitive) 72 | , maybeRootRoute -- | Access the current route for root route 73 | , maybeRoute -- | Access the current route 74 | , routeAttrSet -- | Access the current route attributes as a set 75 | , rootRouteAttrSet -- | Access the current root route attributes as a set 76 | , master -- | Access the master datatype 77 | , sub -- | Access the sub datatype 78 | , rawBody -- | Consume and return the request body as ByteString 79 | , textBody -- | Consume and return the request body as Text 80 | , jsonBody -- | Consume and return the request body as JSON 81 | , header -- | Add a header to the response 82 | , status -- | Set the response status 83 | , file -- | Send a file as response 84 | , filepart -- | Send a part of a file as response 85 | , stream -- | Stream a response 86 | , raw -- | Set the raw response body 87 | , rawBuilder -- | Set the raw response body as a ByteString Builder 88 | , json -- | Set the json response body 89 | , plain -- | Set the plain text response body 90 | , html -- | Set the html response body 91 | , css -- | Set the css response body 92 | , javascript -- | Set the javascript response body 93 | , asContent -- | Set the contentType and a 'Text' body 94 | , next -- | Run the next application in the stack 95 | , getParams -- | Get all params (query or post, not file) 96 | , getParam -- | Get a particular param (query or post, not file) 97 | , getQueryParams -- | Get all query params 98 | , getQueryParam -- | Get a particular query param 99 | , getPostParams -- | Get all post params 100 | , getPostParam -- | Get a particular post param 101 | , getFileParams -- | Get all file params 102 | , getFileParam -- | Get a particular file param 103 | , setCookie -- | Add a cookie to the response 104 | , getCookie -- | Get a cookie from the request 105 | , getCookies -- | Get all cookies from the request 106 | , reqVault -- | Access the vault from the request 107 | , lookupVault -- | Lookup a key in the request vault 108 | , updateVault -- | Update the request vault 109 | 110 | -- * Bare Handlers 111 | , Env(..) 112 | , currentRoute -- | Extract the current `Route` from `RequestData` 113 | 114 | , module Network.HTTP.Types.Status 115 | , module Network.Wai.Middleware.RequestLogger 116 | ) 117 | where 118 | 119 | import Routes.Routes 120 | import Routes.Monad 121 | import Routes.Handler 122 | import Network.HTTP.Types.Status 123 | import Network.Wai.Middleware.RequestLogger 124 | -------------------------------------------------------------------------------- /test/HelloSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} 2 | {- 3 | Test simple routes 4 | -} 5 | module HelloSpec (spec) where 6 | 7 | import Data.Maybe (fromMaybe) 8 | import Network.Wai (Application) 9 | import Wai.Routes 10 | import Data.Aeson (Value(Number), (.=), object) 11 | 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | 15 | import Test.Hspec 16 | import Test.Hspec.Wai 17 | import qualified Test.Hspec.Wai.JSON as H (json) 18 | 19 | ---- A SMALL SUBSITE ---- 20 | 21 | data SubRoute = SubRoute Text 22 | 23 | class RenderRoute master => MasterContract master where 24 | getMasterName :: master -> Text 25 | 26 | mkRouteSub "SubRoute" "MasterContract" [parseRoutes| 27 | / SubHomeR GET 28 | /route SubRouteR GET 29 | |] 30 | 31 | getSubHomeR :: MasterContract master => HandlerS SubRoute master 32 | getSubHomeR = runHandlerM $ do 33 | SubRoute s <- sub 34 | m <- master 35 | plain $ T.concat ["subsite-", s, "-", getMasterName m] 36 | 37 | getSubRouteR :: MasterContract master => HandlerS SubRoute master 38 | getSubRouteR = runHandlerM $ do 39 | showRouteS <- showRouteSub 40 | plain $ T.concat ["this route as sub:", showRouteS SubRouteR, ", this route as master:", showRoute SubRouteR] 41 | 42 | getSubRoute :: master -> Text -> SubRoute 43 | getSubRoute = const SubRoute 44 | 45 | getDefaultSubRoute :: master -> SubRoute 46 | getDefaultSubRoute = const $ SubRoute "default" 47 | 48 | 49 | ---- THE APPLICATION TO BE TESTED ---- 50 | 51 | data MyRoute = MyRoute 52 | 53 | instance MasterContract MyRoute where 54 | getMasterName MyRoute = "MyRoute" 55 | 56 | mkRoute "MyRoute" [parseRoutes| 57 | / HomeR GET 58 | /some-json FooR GET 59 | /post PostR POST 60 | /subsite SubR SubRoute getDefaultSubRoute 61 | /nested NestedR: 62 | / NRootR GET 63 | /abcd AbcdR GET 64 | /nested2 Nested2R: 65 | /subsite SubNestedR SubRoute getDefaultSubRoute 66 | /nested3/#Text Nested3: 67 | /argsub SubNestedArgR SubRoute getSubRoute 68 | |] 69 | 70 | getHomeR :: Handler MyRoute 71 | getHomeR = runHandlerM $ plain "hello" 72 | 73 | getFooR :: Handler MyRoute 74 | getFooR = runHandlerM $ json $ object ["foo" .= Number 23, "bar" .= Number 42] 75 | 76 | -- Post parameters (getParam can also be used for query params) 77 | postPostR :: Handler MyRoute 78 | postPostR = runHandlerM $ do 79 | name <- getParam "name" 80 | plain $ fromMaybe "unnamed" name 81 | 82 | -- Nested routes 83 | getNRootR, getAbcdR :: Handler MyRoute 84 | getNRootR = runHandlerM $ plain "Nested ROOT" 85 | getAbcdR = runHandlerM $ plain "Nested ABCD" 86 | 87 | -- An example of an unrouted handler 88 | handleInfoRequest :: Handler DefaultMaster 89 | handleInfoRequest = runHandlerM $ do 90 | Just (DefaultRoute (_,query)) <- maybeRoute 91 | case lookup "info" query of 92 | -- If an override param "info" was supplied then display info 93 | Just _ -> plain "Info was requested - You are running wai-routes tests" 94 | -- Else, move on to the next handler (i.e. do nothing special) 95 | Nothing -> next 96 | 97 | application :: IO Application 98 | application = return $ waiApp $ do 99 | handler handleInfoRequest 100 | route MyRoute 101 | handler $ runHandlerM $ do 102 | Just (DefaultRoute (r,_)) <- maybeRoute 103 | plain $ T.pack $ show r 104 | -- catchall $ plain "This will never be reached" 105 | 106 | 107 | ---- THE TESTS ---- 108 | 109 | spec :: Spec 110 | spec = with application $ do 111 | describe "GET /" $ 112 | it "responds with 'hello' and has 'Content-Type: text/plain; charset=utf-8'" $ 113 | get "/" `shouldRespondWith` "hello" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 114 | 115 | describe "GET /some-json" $ 116 | it "responds with correct json and has 'Content-Type: application/json; charset=utf-8'" $ 117 | get "/some-json" `shouldRespondWith` [H.json|{foo: 23, bar: 42}|] {matchStatus = 200, matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} 118 | 119 | describe "GET /?info" $ 120 | it "responds with info when requested" $ 121 | get "/?info" `shouldRespondWith` "Info was requested - You are running wai-routes tests" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 122 | 123 | describe "POST /post?name=foobar" $ 124 | it "can read query parameters" $ 125 | postHtmlForm "/post?name=foobar" [("name","ignored")] `shouldRespondWith` "foobar" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 126 | 127 | describe "POST /post" $ 128 | it "can read post body parameters" $ 129 | postHtmlForm "/post" [("name","foobar")] `shouldRespondWith` "foobar" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 130 | 131 | describe "GET /subsite" $ 132 | it "can access the subsite correctly" $ 133 | get "/subsite" `shouldRespondWith` "subsite-default-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 134 | 135 | describe "GET /subsite/route" $ 136 | it "can handle routing across subsite correctly" $ 137 | get "/subsite/route" `shouldRespondWith` "this route as sub:/subsite/route, this route as master:/route" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 138 | 139 | describe "GET /nested" $ 140 | it "can access nested routes root correctly" $ 141 | get "/nested" `shouldRespondWith` "Nested ROOT" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 142 | 143 | describe "GET /nested/abcd" $ 144 | it "can access nested routes correctly" $ 145 | get "/nested/abcd" `shouldRespondWith` "Nested ABCD" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 146 | 147 | describe "GET /nested/nested2/subsite" $ 148 | it "can access the nested subsite correctly" $ 149 | get "/nested/nested2/subsite" `shouldRespondWith` "subsite-default-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 150 | 151 | describe "GET /nested/nested2/nested3/helloworld/argsub" $ 152 | it "can pass route arguments to the nested subsite correctly" $ 153 | get "/nested/nested2/nested3/helloworld/argsub" `shouldRespondWith` "subsite-helloworld-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 154 | 155 | describe "GET /does/not/exist" $ 156 | it "handles catch all routes correctly" $ 157 | get "/does/not/exist" `shouldRespondWith` "[\"does\",\"not\",\"exist\"]" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} 158 | -------------------------------------------------------------------------------- /src/Routes/TH/RenderRoute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | module Routes.TH.RenderRoute 3 | ( -- ** RenderRoute 4 | mkRenderRouteInstance 5 | , mkRouteCons 6 | , mkRenderRouteClauses 7 | ) where 8 | 9 | import Routes.TH.Types 10 | import Language.Haskell.TH (conT) 11 | import Language.Haskell.TH.Syntax 12 | import Data.Bits (xor) 13 | import Data.Maybe (maybeToList) 14 | import Control.Monad (replicateM) 15 | import Data.Text (pack) 16 | import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) 17 | import Routes.Class 18 | 19 | -- | Generate the constructors of a route data type. 20 | mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec]) 21 | mkRouteCons rttypes = 22 | mconcat <$> mapM mkRouteCon rttypes 23 | where 24 | mkRouteCon (ResourceLeaf res) = 25 | return ([con], []) 26 | where 27 | con = NormalC (mkName $ resourceName res) 28 | $ map (\x -> (notStrict, x)) 29 | $ concat [singles, multi, sub] 30 | singles = concatMap toSingle $ resourcePieces res 31 | toSingle Static{} = [] 32 | toSingle (Dynamic typ) = [typ] 33 | 34 | multi = maybeToList $ resourceMulti res 35 | 36 | sub = 37 | case resourceDispatch res of 38 | Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] 39 | _ -> [] 40 | 41 | mkRouteCon (ResourceParent name _check pieces children) = do 42 | (cons, decs) <- mkRouteCons children 43 | #if MIN_VERSION_template_haskell(2,12,0) 44 | dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq]) 45 | #else 46 | dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] 47 | #endif 48 | return ([con], dec : decs) 49 | where 50 | con = NormalC (mkName name) 51 | $ map (\x -> (notStrict, x)) 52 | $ singles ++ [ConT $ mkName name] 53 | 54 | singles = concatMap toSingle pieces 55 | toSingle Static{} = [] 56 | toSingle (Dynamic typ) = [typ] 57 | 58 | -- | Clauses for the 'renderRoute' method. 59 | mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] 60 | mkRenderRouteClauses = 61 | mapM go 62 | where 63 | isDynamic Dynamic{} = True 64 | isDynamic _ = False 65 | 66 | go (ResourceParent name _check pieces children) = do 67 | let cnt = length $ filter isDynamic pieces 68 | dyns <- replicateM cnt $ newName "dyn" 69 | child <- newName "child" 70 | let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] 71 | 72 | pack' <- [|pack|] 73 | tsp <- [|toPathPiece|] 74 | let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns 75 | 76 | childRender <- newName "childRender" 77 | let rr = VarE childRender 78 | childClauses <- mkRenderRouteClauses children 79 | 80 | a <- newName "a" 81 | b <- newName "b" 82 | 83 | colon <- [|(:)|] 84 | let cons y ys = InfixE (Just y) colon (Just ys) 85 | let pieces' = foldr cons (VarE a) piecesSingle 86 | 87 | let body = LamE [TupP [VarP a, VarP b]] (TupE 88 | #if MIN_VERSION_template_haskell(2,16,0) 89 | $ map Just 90 | #endif 91 | [pieces', VarE b] 92 | ) `AppE` (rr `AppE` VarE child) 93 | 94 | return $ Clause [pat] (NormalB body) [FunD childRender childClauses] 95 | 96 | go (ResourceLeaf res) = do 97 | let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) 98 | dyns <- replicateM cnt $ newName "dyn" 99 | sub <- 100 | case resourceDispatch res of 101 | Subsite{} -> return <$> newName "sub" 102 | _ -> return [] 103 | let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub 104 | 105 | pack' <- [|pack|] 106 | tsp <- [|toPathPiece|] 107 | let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns 108 | 109 | piecesMulti <- 110 | case resourceMulti res of 111 | Nothing -> return $ ListE [] 112 | Just{} -> do 113 | tmp <- [|toPathMultiPiece|] 114 | return $ tmp `AppE` VarE (last dyns) 115 | 116 | body <- 117 | case sub of 118 | [x] -> do 119 | rr <- [|renderRoute|] 120 | a <- newName "a" 121 | b <- newName "b" 122 | 123 | colon <- [|(:)|] 124 | let cons y ys = InfixE (Just y) colon (Just ys) 125 | let pieces = foldr cons (VarE a) piecesSingle 126 | 127 | return $ LamE [TupP [VarP a, VarP b]] (TupE 128 | #if MIN_VERSION_template_haskell(2,16,0) 129 | $ map Just 130 | #endif 131 | [pieces, VarE b] 132 | ) `AppE` (rr `AppE` VarE x) 133 | _ -> do 134 | colon <- [|(:)|] 135 | let cons a b = InfixE (Just a) colon (Just b) 136 | return $ TupE 137 | #if MIN_VERSION_template_haskell(2,16,0) 138 | $ map Just 139 | #endif 140 | [foldr cons piecesMulti piecesSingle, ListE []] 141 | 142 | return $ Clause [pat] (NormalB body) [] 143 | 144 | mkPieces _ _ [] _ = [] 145 | mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns 146 | mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns 147 | mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120" 148 | 149 | -- | Generate the 'RenderRoute' instance. 150 | -- 151 | -- This includes both the 'Route' associated type and the 152 | -- 'renderRoute' method. This function uses both 'mkRouteCons' and 153 | -- 'mkRenderRouteClasses'. 154 | mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] 155 | mkRenderRouteInstance cxt typ ress = do 156 | cls <- mkRenderRouteClauses ress 157 | (cons, decs) <- mkRouteCons ress 158 | #if MIN_VERSION_template_haskell(2,15,0) 159 | did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) 160 | let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) 161 | #elif MIN_VERSION_template_haskell(2,12,0) 162 | did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) 163 | let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) 164 | #else 165 | did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) 166 | let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) 167 | #endif 168 | return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) 169 | [ did 170 | , FunD (mkName "renderRoute") cls 171 | ] 172 | : sds ++ decs 173 | where 174 | clazzes standalone = if standalone `xor` null cxt then 175 | clazzes' 176 | else 177 | [] 178 | clazzes' = [''Show, ''Eq, ''Read] 179 | 180 | notStrict :: Bang 181 | notStrict = Bang NoSourceUnpackedness NoSourceStrictness 182 | 183 | instanceD :: Cxt -> Type -> [Dec] -> Dec 184 | instanceD = InstanceD Nothing 185 | -------------------------------------------------------------------------------- /examples/digestive-functors-hamlet/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | {- 5 | Example using digestive functors with hamlet templates. 6 | We demonstrate composing nested forms with validation, 7 | nested views defined in hamlet templates, 8 | and how to wire it together with wai-routes. 9 | TODO: Perhaps create a digestive-functors-wai-routes package 10 | -} 11 | 12 | import Wai.Routes 13 | 14 | import Control.Applicative ((<$>), (<*>)) 15 | 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Lazy as TL 19 | import Data.Maybe (isJust, maybeToList) 20 | 21 | import Network.Wai.Handler.Warp (run) 22 | import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) 23 | 24 | import Text.Hamlet (hamlet, HtmlUrl, Html, shamlet) 25 | import Text.Blaze.Html5 (toHtml) 26 | import Text.Blaze.Html.Renderer.Text (renderHtml) 27 | import Text.Digestive.Util (readMaybe) 28 | import Text.Digestive.Blaze.Html5 (inputSubmit, inputSelect, inputText, errorList, childErrorList) 29 | import Text.Digestive (Form, View, getForm, postForm, FormInput(TextInput), text, check, (.:), Result(Error, Success), validate, choice, subView) 30 | 31 | -- Our master datatype 32 | data MyApp = MyApp 33 | 34 | -- The 'Route' type represents the type of the typesafe Routes generated by wai-routes 35 | -- 'Route MyApp' means the 'Route' type generated for the master datatype 'MyApp' 36 | -- We alias it to 'MyRoute' for convenience 37 | type MyRoute = Route MyApp 38 | 39 | -- Generate routes 40 | -- We handle both GET (which displays the form) and POST (to submit the form) 41 | mkRoute "MyApp" [parseRoutes| 42 | / HomeR GET POST 43 | |] 44 | 45 | -- Handle Displaying the form 46 | getHomeR :: Handler MyApp 47 | getHomeR = runHandlerM $ do 48 | -- On a GET request, we simply run the releaseForm to get a digestive-functor view definition 49 | view <- getForm "release" releaseForm 50 | -- This is some boilerplate to convert the digestive-functor view to appropriate format 51 | let view' = fmap toHtml view 52 | -- Then we render the view definition with a hamlet template called releaseView 53 | html $ TL.toStrict $ renderHtml $ releaseView view' showRouteQuery 54 | 55 | -- Handle posts made to the form 56 | postHomeR :: Handler MyApp 57 | postHomeR = runHandlerM $ do 58 | -- Run the releaseForm to get a view definition and a result 59 | (view, result) <- postForm "release" releaseForm fetchParam 60 | -- Again boilerplate to convert the digestive-functor view to appropriate format 61 | let view' = fmap toHtml view 62 | -- Then we render the view definition differently, depending on the result 63 | html $ TL.toStrict $ renderHtml $ case result of 64 | -- If the POST had incomplete data, or failed validation, then just display the original release form 65 | -- The releaseView has code to display any errors to the user. We could also have used a dedicated errorView 66 | Nothing -> releaseView view' showRouteQuery 67 | -- If we managed to get a complete result, then display the result using a hamlet template called releaseReceivedView 68 | Just release -> releaseReceivedView release view' showRouteQuery 69 | where 70 | -- This function is the link between wai-routes and digestive-functors 71 | -- It tells digestive-functors how to fetch form parameters in a wai-route handler monad 72 | fetchParam _encType = return $ \path -> 73 | -- digestive-functor sends us a 'path' i.e. a list of path fragments 74 | -- To convert a path to a parameter, we just use '.' separated text 75 | -- TODO: Handle files. We currently always return a TextInput 76 | getPostParam (T.intercalate "." path) >>= return . map TextInput . maybeToList 77 | 78 | -- Define Application using RouteM Monad 79 | application :: RouteM () 80 | application = do 81 | middleware logStdoutDev 82 | route MyApp 83 | catchall $ staticApp $ defaultFileServerSettings "static" 84 | 85 | -- Run the application 86 | main :: IO () 87 | main = do 88 | putStrLn "Starting server on port 8080" 89 | run 8080 (waiApp application) 90 | 91 | 92 | 93 | -- THE ACTUAL BUSINESS LOGIC AND TEMPLATES FOLLOW 94 | 95 | -- The User datatype 96 | data User = User 97 | { userName :: Text 98 | , userMail :: Text 99 | } deriving (Show) 100 | 101 | -- A Form to fetch a user's details 102 | userForm :: Monad m => Form Text m User 103 | userForm = User 104 | <$> "name" .: text Nothing 105 | -- We validate the email address 106 | <*> "mail" .: check "Not a valid email address" checkEmail (text Nothing) 107 | where 108 | checkEmail :: Text -> Bool 109 | checkEmail = isJust . T.find (== '@') 110 | 111 | -- Hamlet template to display a User 112 | -- Note the use of errorList to display failed validation errors for email 113 | userView :: View Html -> Html 114 | userView view = [shamlet| 115 | <label name="name"> Name: 116 | #{inputText "name" view} 117 | <br> 118 | #{errorList "mail" view} 119 | <label name="mail"> Email address: 120 | #{inputText "mail" view} 121 | <br> 122 | |] 123 | 124 | 125 | -- The Package data type 126 | data Package = Package Text Version Category 127 | deriving (Show) 128 | 129 | -- Package version number 130 | type Version = [Int] 131 | 132 | -- Package category 133 | data Category = Web | Text | Math 134 | deriving (Bounded, Enum, Eq, Show) 135 | 136 | -- A Form to fetch a package's details 137 | packageForm :: Monad m => Form Text m Package 138 | packageForm = Package 139 | <$> "name" .: text Nothing 140 | -- We validate version numbers 141 | <*> "version" .: validate validateVersion (text (Just "0.0.0.1")) 142 | <*> "category" .: choice categories Nothing 143 | where 144 | -- Category can only be selected from a prepopulated list 145 | -- [minBound..maxBound] is a shortcut to enumerate all the constructors of Category 146 | categories = [(x, T.pack (show x)) | x <- [minBound .. maxBound]] 147 | -- Version validator 148 | validateVersion = maybe (Error "Cannot parse version") Success . 149 | mapM (readMaybe . T.unpack) . T.split (== '.') 150 | 151 | -- A Release is a Package's details uploaded by a User 152 | data Release = Release User Package 153 | deriving (Show) 154 | 155 | -- Form to capture a release 156 | -- Note that this is simply composed of the user and package sub-forms 157 | releaseForm :: Monad m => Form Text m Release 158 | releaseForm = Release 159 | <$> "author" .: userForm 160 | <*> "package" .: packageForm 161 | 162 | -- Hamlet template to display a Release 163 | -- Note that we simply use userView as a sub-view 164 | -- We could also have made a separate packageView sub-view 165 | -- Note the use of childErrorList to display all validation errors related to packages 166 | releaseView :: View Html -> HtmlUrl MyRoute 167 | releaseView view = [hamlet| 168 | <form action=@{HomeR} method=POST> 169 | <h2>Author 170 | #{userView $ subView "author" view} 171 | <h2>Package 172 | #{childErrorList "package" view} 173 | <label name="package.name"> Name: 174 | #{inputText "package.name" view} 175 | <br> 176 | <label name="package.version"> Version: 177 | #{inputText "package.version" view} 178 | <br> 179 | <label name="package.category"> Category: 180 | #{inputSelect "package.category" view} 181 | <br> 182 | #{inputSubmit "Submit"} 183 | |] 184 | 185 | -- Hamlet template to display a correctly POSTed Release 186 | -- We simply print the contents of the release data structure in a <pre> tag 187 | -- And then use the previously defined releaseView sub-view to show the form. Don't repeat yourself! 188 | releaseReceivedView :: Release -> View Html -> HtmlUrl MyRoute 189 | releaseReceivedView release view = [hamlet| 190 | <h1> Release received 191 | <pre> #{show $ release} 192 | ^{releaseView view} 193 | |] 194 | -------------------------------------------------------------------------------- /src/Routes/TH/Dispatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} 2 | module Routes.TH.Dispatch 3 | ( MkDispatchSettings (..) 4 | , mkDispatchClause 5 | , defaultGetHandler 6 | ) where 7 | 8 | import Prelude hiding (exp) 9 | import Language.Haskell.TH.Syntax 10 | import Web.PathPieces 11 | import Data.Maybe (catMaybes) 12 | import Control.Monad (forM) 13 | import Data.List (foldl') 14 | import Control.Arrow (second) 15 | import System.Random (randomRIO) 16 | import Routes.TH.Types 17 | import Data.Char (toLower) 18 | 19 | data MkDispatchSettings b site c = MkDispatchSettings 20 | { mdsRunHandler :: Q Exp 21 | , mdsSubDispatcher :: Q Exp 22 | , mdsGetPathInfo :: Q Exp 23 | , mdsSetPathInfo :: Q Exp 24 | , mdsMethod :: Q Exp 25 | , mds404 :: Q Exp 26 | , mds405 :: Q Exp 27 | , mdsGetHandler :: Maybe String -> String -> Q Exp 28 | , mdsUnwrapper :: Exp -> Q Exp 29 | } 30 | 31 | data SDC = SDC 32 | { clause404 :: Clause 33 | , extraParams :: [Exp] 34 | , extraCons :: [Exp] 35 | , envExp :: Exp 36 | , reqExp :: Exp 37 | } 38 | 39 | -- | A simpler version of Routes.TH.Dispatch.mkDispatchClause, based on 40 | -- view patterns. 41 | -- 42 | -- Since 1.4.0 43 | mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause 44 | mkDispatchClause MkDispatchSettings {..} resources = do 45 | suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) 46 | envName <- newName $ "env" ++ show suffix 47 | reqName <- newName $ "req" ++ show suffix 48 | helperName <- newName $ "helper" ++ show suffix 49 | 50 | let envE = VarE envName 51 | reqE = VarE reqName 52 | helperE = VarE helperName 53 | 54 | clause404' <- mkClause404 envE reqE 55 | getPathInfo <- mdsGetPathInfo 56 | let pathInfo = getPathInfo `AppE` reqE 57 | 58 | let sdc = SDC 59 | { clause404 = clause404' 60 | , extraParams = [] 61 | , extraCons = [] 62 | , envExp = envE 63 | , reqExp = reqE 64 | } 65 | clauses <- mapM (go sdc) resources 66 | 67 | return $ Clause 68 | [VarP envName, VarP reqName] 69 | (NormalB $ helperE `AppE` pathInfo) 70 | [FunD helperName $ clauses ++ [clause404']] 71 | where 72 | handlePiece :: Piece a -> Q (Pat, Maybe Exp) 73 | handlePiece (Static str) = return (LitP $ StringL str, Nothing) 74 | handlePiece (Dynamic _) = do 75 | x <- newName "dyn" 76 | let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) 77 | return (pat, Just $ VarE x) 78 | 79 | handlePieces :: [Piece a] -> Q ([Pat], [Exp]) 80 | handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece 81 | 82 | mkCon :: String -> [Exp] -> Exp 83 | mkCon name = foldl' AppE (ConE $ mkName name) 84 | 85 | mkPathPat :: Pat -> [Pat] -> Pat 86 | mkPathPat final = 87 | foldr addPat final 88 | where 89 | addPat x y = ConP '(:) [x, y] 90 | 91 | go :: SDC -> ResourceTree a -> Q Clause 92 | go sdc (ResourceParent name _check pieces children) = do 93 | (pats, dyns) <- handlePieces pieces 94 | let sdc' = sdc 95 | { extraParams = extraParams sdc ++ dyns 96 | , extraCons = extraCons sdc ++ [mkCon name dyns] 97 | } 98 | childClauses <- mapM (go sdc') children 99 | 100 | restName <- newName "rest" 101 | let restE = VarE restName 102 | restP = VarP restName 103 | 104 | helperName <- newName $ "helper" ++ name 105 | let helperE = VarE helperName 106 | 107 | return $ Clause 108 | [mkPathPat restP pats] 109 | (NormalB $ helperE `AppE` restE) 110 | [FunD helperName $ childClauses ++ [clause404 sdc]] 111 | go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do 112 | (pats, dyns) <- handlePieces pieces 113 | 114 | (chooseMethod, finalPat) <- handleDispatch dispatch dyns 115 | 116 | return $ Clause 117 | [mkPathPat finalPat pats] 118 | (NormalB chooseMethod) 119 | [] 120 | where 121 | handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) 122 | handleDispatch dispatch' dyns = 123 | case dispatch' of 124 | Methods multi methods -> do 125 | (finalPat, mfinalE) <- 126 | case multi of 127 | Nothing -> return (ConP '[] [], Nothing) 128 | Just _ -> do 129 | multiName <- newName "multi" 130 | let pat = ViewP (VarE 'fromPathMultiPiece) 131 | (ConP 'Just [VarP multiName]) 132 | return (pat, Just $ VarE multiName) 133 | 134 | let dynsMulti = 135 | case mfinalE of 136 | Nothing -> dyns 137 | Just e -> dyns ++ [e] 138 | route' = foldl' AppE (ConE (mkName name)) dynsMulti 139 | route = foldr AppE route' extraCons 140 | jroute = ConE 'Just `AppE` route 141 | allDyns = extraParams ++ dynsMulti 142 | mkRunExp mmethod = do 143 | runHandlerE <- mdsRunHandler 144 | handlerE' <- mdsGetHandler mmethod name 145 | handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns 146 | return $ runHandlerE 147 | `AppE` handlerE 148 | `AppE` envExp 149 | `AppE` jroute 150 | `AppE` reqExp 151 | 152 | func <- 153 | case methods of 154 | [] -> mkRunExp Nothing 155 | _ -> do 156 | getMethod <- mdsMethod 157 | let methodE = getMethod `AppE` reqExp 158 | matches <- forM methods $ \method -> do 159 | exp <- mkRunExp (Just method) 160 | return $ Match (LitP $ StringL method) (NormalB exp) [] 161 | match405 <- do 162 | runHandlerE <- mdsRunHandler 163 | handlerE <- mds405 164 | let exp = runHandlerE 165 | `AppE` handlerE 166 | `AppE` envExp 167 | `AppE` jroute 168 | `AppE` reqExp 169 | return $ Match WildP (NormalB exp) [] 170 | return $ CaseE methodE $ matches ++ [match405] 171 | 172 | return (func, finalPat) 173 | Subsite _ getSub -> do 174 | restPath <- newName "restPath" 175 | setPathInfoE <- mdsSetPathInfo 176 | subDispatcherE <- mdsSubDispatcher 177 | runHandlerE <- mdsRunHandler 178 | sub <- newName "sub" 179 | let allDyns = extraParams ++ dyns 180 | sroute <- newName "sroute" 181 | let sub2 = LamE [VarP sub] 182 | (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns) 183 | let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp 184 | route' = foldl' AppE (ConE (mkName name)) dyns 185 | route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons 186 | exp = subDispatcherE 187 | `AppE` runHandlerE 188 | `AppE` sub2 189 | `AppE` route 190 | `AppE` envExp 191 | `AppE` reqExp' 192 | return (exp, VarP restPath) 193 | 194 | mkClause404 envE reqE = do 195 | handler <- mds404 196 | runHandler <- mdsRunHandler 197 | let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE 198 | return $ Clause [WildP] (NormalB exp) [] 199 | 200 | defaultGetHandler :: Maybe String -> String -> Q Exp 201 | defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s 202 | defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s 203 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # From https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-complex.yml 2 | 3 | # This is the complex Travis configuration, which is intended for use 4 | # on open source libraries which need compatibility across multiple GHC 5 | # versions, must work with cabal-install, and should be 6 | # cross-platform. For more information and other options, see: 7 | # 8 | # https://docs.haskellstack.org/en/stable/travis_ci/ 9 | # 10 | # Copy these contents into the root directory of your Github project in a file 11 | # named .travis.yml 12 | 13 | # Use new container infrastructure to enable caching 14 | sudo: false 15 | 16 | # Do not choose a language; we provide our own build tools. 17 | language: generic 18 | 19 | # Caching so the next build will be fast too. 20 | cache: 21 | directories: 22 | - $HOME/.ghc 23 | - $HOME/.cabal 24 | - $HOME/.stack 25 | - $TRAVIS_BUILD_DIR/.stack-work 26 | 27 | # The different configurations we want to test. We have BUILD=cabal which uses 28 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 29 | # of those below. 30 | # 31 | # We set the compiler values here to tell Travis to use a different 32 | # cache file per set of arguments. 33 | # 34 | # If you need to have different apt packages for each combination in the 35 | # matrix, you can use a line such as: 36 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 37 | matrix: 38 | include: 39 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 40 | # https://github.com/hvr/multi-ghc-travis 41 | #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 42 | # compiler: ": #GHC 7.0.4" 43 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 44 | #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 45 | # compiler: ": #GHC 7.2.2" 46 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 47 | #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 48 | # compiler: ": #GHC 7.4.2" 49 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 50 | #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 51 | # compiler: ": #GHC 7.6.3" 52 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 53 | #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 54 | # compiler: ": #GHC 7.8.4" 55 | # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 56 | #- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 57 | # compiler: ": #GHC 7.10.3" 58 | # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 59 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 60 | compiler: ": #GHC 8.0.2" 61 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 62 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 63 | compiler: ": #GHC 8.2.2" 64 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 65 | - env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 66 | compiler: ": #GHC 8.4.4" 67 | addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 68 | - env: BUILD=cabal GHCVER=8.6.3 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 69 | compiler: ": #GHC 8.6.3" 70 | addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 71 | 72 | # Build with the newest GHC and cabal-install. This is an accepted failure, 73 | # see below. 74 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 75 | compiler: ": #GHC HEAD" 76 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 77 | 78 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 79 | # variable, such as using --stack-yaml to point to a different file. 80 | - env: BUILD=stack ARGS="" 81 | compiler: ": #stack default" 82 | addons: {apt: {packages: [libgmp-dev]}} 83 | 84 | #- env: BUILD=stack ARGS="--resolver lts-2" 85 | # compiler: ": #stack 7.8.4" 86 | # addons: {apt: {packages: [libgmp-dev]}} 87 | 88 | #- env: BUILD=stack ARGS="--resolver lts-3" 89 | # compiler: ": #stack 7.10.2" 90 | # addons: {apt: {packages: [libgmp-dev]}} 91 | 92 | #- env: BUILD=stack ARGS="--resolver lts-6" 93 | # compiler: ": #stack 7.10.3" 94 | # addons: {apt: {packages: [libgmp-dev]}} 95 | 96 | #- env: BUILD=stack ARGS="--resolver lts-7" 97 | # compiler: ": #stack 8.0.1" 98 | # addons: {apt: {packages: [libgmp-dev]}} 99 | 100 | - env: BUILD=stack ARGS="--resolver lts-9" 101 | compiler: ": #stack 8.0.2" 102 | addons: {apt: {packages: [libgmp-dev]}} 103 | 104 | - env: BUILD=stack ARGS="--resolver lts-11" 105 | compiler: ": #stack 8.2.2" 106 | addons: {apt: {packages: [libgmp-dev]}} 107 | 108 | - env: BUILD=stack ARGS="--resolver lts-12" 109 | compiler: ": #stack 8.4.4" 110 | addons: {apt: {packages: [libgmp-dev]}} 111 | 112 | - env: BUILD=stack ARGS="--resolver lts-13" 113 | compiler: ": #stack 8.6.3" 114 | addons: {apt: {packages: [libgmp-dev]}} 115 | 116 | # Nightly builds are allowed to fail 117 | - env: BUILD=stack ARGS="--resolver nightly" 118 | compiler: ": #stack nightly" 119 | addons: {apt: {packages: [libgmp-dev]}} 120 | 121 | # Build on macOS in addition to Linux 122 | - env: BUILD=stack ARGS="" 123 | compiler: ": #stack default osx" 124 | os: osx 125 | 126 | # Travis includes an macOS which is incompatible with GHC 7.8.4 127 | #- env: BUILD=stack ARGS="--resolver lts-2" 128 | # compiler: ": #stack 7.8.4 osx" 129 | # os: osx 130 | 131 | #- env: BUILD=stack ARGS="--resolver lts-3" 132 | # compiler: ": #stack 7.10.2 osx" 133 | # os: osx 134 | 135 | #- env: BUILD=stack ARGS="--resolver lts-6" 136 | # compiler: ": #stack 7.10.3 osx" 137 | # os: osx 138 | 139 | #- env: BUILD=stack ARGS="--resolver lts-7" 140 | # compiler: ": #stack 8.0.1 osx" 141 | # os: osx 142 | 143 | - env: BUILD=stack ARGS="--resolver lts-9" 144 | compiler: ": #stack 8.0.2 osx" 145 | os: osx 146 | 147 | - env: BUILD=stack ARGS="--resolver lts-11" 148 | compiler: ": #stack 8.2.2 osx" 149 | os: osx 150 | 151 | - env: BUILD=stack ARGS="--resolver lts-12" 152 | compiler: ": #stack 8.4.4 osx" 153 | os: osx 154 | 155 | - env: BUILD=stack ARGS="--resolver lts-13" 156 | compiler: ": #stack 8.6.3 osx" 157 | os: osx 158 | 159 | - env: BUILD=stack ARGS="--resolver nightly" 160 | compiler: ": #stack nightly osx" 161 | os: osx 162 | 163 | allow_failures: 164 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 165 | - env: BUILD=stack ARGS="--resolver nightly" 166 | 167 | before_install: 168 | # Using compiler above sets CC to an invalid value, so unset it 169 | - unset CC 170 | 171 | # We want to always allow newer versions of packages when building on GHC HEAD 172 | - CABALARGS="" 173 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 174 | 175 | # Download and unpack the stack executable 176 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 177 | - mkdir -p ~/.local/bin 178 | - | 179 | if [ `uname` = "Darwin" ] 180 | then 181 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 182 | else 183 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 184 | fi 185 | 186 | # Use the more reliable S3 mirror of Hackage 187 | mkdir -p $HOME/.cabal 188 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 189 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 190 | 191 | 192 | install: 193 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 194 | - if [ -f configure.ac ]; then autoreconf -i; fi 195 | - | 196 | set -ex 197 | case "$BUILD" in 198 | stack) 199 | # Add in extra-deps for older snapshots, as necessary 200 | # 201 | # This is disabled by default, as relying on the solver like this can 202 | # make builds unreliable. Instead, if you have this situation, it's 203 | # recommended that you maintain multiple stack-lts-X.yaml files. 204 | 205 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 206 | # stack --no-terminal $ARGS build cabal-install && \ 207 | # stack --no-terminal $ARGS solver --update-config) 208 | 209 | # Build the dependencies 210 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 211 | ;; 212 | cabal) 213 | cabal --version 214 | travis_retry cabal update 215 | 216 | # Get the list of packages from the stack.yaml file. Note that 217 | # this will also implicitly run hpack as necessary to generate 218 | # the .cabal files needed by cabal-install. 219 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 220 | 221 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 222 | ;; 223 | esac 224 | set +ex 225 | 226 | script: 227 | - | 228 | set -ex 229 | case "$BUILD" in 230 | stack) 231 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 232 | ;; 233 | cabal) 234 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 235 | 236 | ORIGDIR=$(pwd) 237 | for dir in $PACKAGES 238 | do 239 | cd $dir 240 | cabal check || [ "$CABALVER" == "1.16" ] 241 | cabal sdist 242 | PKGVER=$(cabal info . | awk '{print $2;exit}') 243 | SRC_TGZ=$PKGVER.tar.gz 244 | cd dist 245 | tar zxfv "$SRC_TGZ" 246 | cd "$PKGVER" 247 | cabal configure --enable-tests --ghc-options -O0 248 | cabal build 249 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 250 | cabal test 251 | else 252 | cabal test --show-details=streaming --log=/dev/stdout 253 | fi 254 | cd $ORIGDIR 255 | done 256 | ;; 257 | esac 258 | set +ex 259 | 260 | notifications: 261 | webhooks: 262 | urls: 263 | - https://webhooks.gitter.im/e/54082bcac9f71b052848 264 | on_success: always # options: [always|never|change] default: always 265 | on_failure: always # options: [always|never|change] default: always 266 | on_start: never # options: [always|never|change] default: always 267 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.10.4-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) 2 | ==================================== 3 | 4 | Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. 5 | 6 | Wai-routes is based on the Haskell [Web Application Interface](http://hackage.haskell.org/package/wai) and uses it for most of the heavy lifting. It also provides a convenient but thin veneer over most of the wai API so it is unnecessary to directly use raw wai APIs when building web apps. 7 | 8 | Much of Wai-route's typesafe URL functionality was pulled from the corresponding features in [Yesod](http://www.yesodweb.com/), and indeed the underlying aim of wai-routes is - *"To provide a similar level of typesafe URL functionality to Wai applications as is available to Yesod applications."*. 9 | 10 | ***Note*** - If you are looking for typesafe URLs for Snap, take a look at [Snap-Routes](https://github.com/ajnsit/snap-routes) - A port of this library for Snap. 11 | 12 | Features 13 | ========== 14 | 15 | Wai-routes adds the following features on top of wai - 16 | 17 | - Typesafe URLs, including automatic boilerplate generation using TH. Including features such as - 18 | - Nested Routes 19 | - Subsites 20 | - Route Annotations 21 | - Seamlessly mix and match "unrouted" request handlers with typesafe routing. 22 | - Sitewide Master data which is passed to all handlers and can be used for persistent data (like DB connections) 23 | - Easy to use Handler Monad which allows direct access to request and master data 24 | - Easy composition of multiple routes and middleware to construct an application 25 | - Ability to abort processing and pass control to the next application in the wai stack 26 | - Streaming responses 27 | 28 | 29 | Performance 30 | =========== 31 | 32 | When it comes to performance, Wai-routes compares quite favorably with other Haskell web development micro frameworks. 33 | 34 | See more details here - [philopon/apiary-benchmark](https://github.com/philopon/apiary-benchmark) 35 | 36 | ![result](./benchmark/result-tama.png) 37 | 38 | 39 | Example Usage 40 | ============= 41 | 42 | Wai-routes comes with several examples in the `examples/` directory. New examples are being added regularly. 43 | 44 | **Example 1. Hello World** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/hello-world/src) 45 | 46 | A simple hello-world web app with two interlinked pages. This provides the simplest example of using routing and linking between pages with typesafe routes. 47 | 48 | **Example 2. Hello World with Subsites** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/subsites/src) 49 | 50 | Similar functionality as the first example, but uses a hello world subsites to provide the hello world functionality. A subsite is an independently developed site that can be embedded into a parent site as long as the parent site satisfies a particular api contract. It's easy to swap out subsites for different functionality as long as the api contract remains constant. 51 | 52 | **Example 3. Using Blaze-HTML to generate HTML** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/blaze-html/src) 53 | 54 | A simple example of how to generate HTML using blaze-html combinators in your handlers. 55 | 56 | **Example 4. Using Shakespearean Templates (hamlet, cassius, lucius, julius) to generate HTML/CSS/JS** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/shakespeare/src) 57 | 58 | A simple example of how to generate HTML/CSS/JS using shakespearean templates. You can use both external and inline templates. 59 | 60 | **Example 5. Using Digestive Functors and Hamlet** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/digestive-functors-hamlet/src) 61 | 62 | An example of using digestive functors for form handling and hamlet for templating. It demonstrates composing nested forms with validation, nested views defined in hamlet templates, and how to wire it together with wai-routes. 63 | 64 | **Example 6. Building a JSON REST Service** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/rest-json/src) 65 | 66 | Provides a simple example of how to build JSON REST services with wai-routes. Uses Aeson for JSON conversion. Note that this example just demonstrates the web facing side of the application. It doesn't permanently persist data, and is also not threadsafe. You must use a more robust data storage mechanism in production! An example of doing this with a Relational DB adapter (like persistent) is in the works. 67 | 68 | **Example 7. Stream a response** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/streaming-response/src) 69 | 70 | Wai has had the ability to stream content for a long time. Now wai-routes exposes this functionality with the `stream` function. This example shows how to stream content in a handler. Note that most browsers using default settings will not show content as it is being streamed. You can use "curl" to observe the effect of streaming. E.g. - `curl localhost:8080` will dump the data as it is being streamed from the server. 71 | 72 | **Example 8. Kitchen sink** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/kitchen/src) 73 | 74 | *Work in progress*. Demonstrates all major features in wai-routes. 75 | 76 | **Example 9. Unrouted** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/unrouted/src) 77 | 78 | Demonstrates "unrouted" applications. These require no TH, or GHC extensions. Basically allow you to sequence request handlers in a cascade, with each handler having the full functionality of HandlerM monad available to them. Each handler also has access to untyped (but parsed) route information. Unrouted handlers are freely mixable with typesafe routing. 79 | 80 | **Example 10. Typesafe "Bare" Wai routing** - [Code](https://github.com/ajnsit/wai-routes/tree/master/examples/bare-wai/src) 81 | 82 | Demonstrates writing no-overhead "bare" wai applications with routing. Wai-routes handlers are simple functions that return wai responses. This means that you are free to use typesafe routing, but without using runHandlerM, instead accessing the master datatype and the route args as arguments passed to the handler function. 83 | 84 | Deployment 85 | ========== 86 | 87 | The current recommended route (pun not intended) for deploying wai-routes apps is [keter](http://hackage.haskell.org/package/keter). You need to read the port from the environment variables - 88 | 89 | -- Run the application 90 | main :: IO () 91 | main = do 92 | port' <- getEnv "PORT" 93 | let port = read port' 94 | run port $ waiApp application 95 | 96 | Then put something like this in `config/keter.yaml` - 97 | 98 | exec: ../path/to/executable 99 | host: mydomainname.example.com 100 | 101 | Then create a tarball with `config/keter.yaml`, `path/to/executable`, and any other files needed at runtime for your application. Rename the tarball to have a `.keter` extension. 102 | 103 | Upload that file to your server's `incoming` folder for keter to pick it up. You obviously need keter already installed and configured properly at the server. 104 | 105 | Planned Features 106 | ==================== 107 | 108 | The following features are planned for later releases - 109 | 110 | - Seamless websocket support 111 | - Development mode 112 | - Scaffolding 113 | - Better documentation, and a getting started tutorial 114 | - More tests and code coverage 115 | 116 | 117 | Changelog 118 | ========= 119 | 120 | * 0.10.4: Bump deps. Include base-4.12, aeson-1.4, hspec-2.6. Add MonadFail instance for HandlerMI. GHC 8.6 compatibility. 121 | * 0.10.3: Bump deps. Include base-4.11, aeson-1.3, hspec-2.5, template-haskell-2.13. 122 | * 0.10.2: http-types-0.12.1. 123 | * 0.10.1: Compatibility with template-haskell 2.12. 124 | * 0.10.0: Allow aeson v1.2. Routing improvements. Remove wai-app-static dependency. Add nix expression. 125 | * 0.9.10: Aeson and hspec version bump. 126 | * 0.9.9 : GHC 8 compatibility. Change namespace from Network.Wai.Middleware.Routes -> Wai.Routes 127 | * 0.9.8 : Allow Data.Default-0.1.0. Allow comments in route definitions. Some other minor changes. 128 | * 0.9.7 : Allow Aeson-0.11. Export Env, RequestData, and show/readRoute to enable "bare" handlers. 129 | * 0.9.6 : Subsites now receive parent route arguments, in line with regular nested routes 130 | * 0.9.5 : Subsites now play well with hierarchical routes 131 | * 0.9.4 : Wai-3.2 compatibility. Added functions to manipulate wai "vault". Minor changes to internal types. 132 | * 0.9.3 : Added `content` and `whenContent`. Allow http-types-0.9. 133 | * 0.9.2 : Fix failing test in release tarball. (Only tests changed). 134 | * 0.9.1 : Greatly simplified subsites (simply use mkRouteSub). Added 'mountedAppHandler' to integrate external full wai apps. 135 | * 0.9.0 : Support for "unrouted" handlers. API changes to avoid returning lazy text or bytestring. Methods to fetch post/file params. Removed 'HandlerMM' and made 'Handler' more useful. 136 | * 0.8.1 : Bumped dependencies. Added 'HandlerMM' type alias 137 | * 0.8.0 : Replaced 'show/renderRoute' with 'show/renderRouteSub' and 'show/renderRouteMaster'. Added functions to access request headers (reqHeader/s), send a part of a file (filepart). Auto infer mime-types when sending files. Added cookie handling functions (get/setCookie/s). Added 'sub' to allow access to subsite datatype. 138 | * 0.7.3 : Added 'stream' to stream responses. Added 'asContent', 'css', and 'javascript' functions. 139 | * 0.7.2 : Added 'file' to send a raw file directly, 'rawBody' and 'jsonBody' to consume request body. Refactored RouteM to add 'catchAll' and 'waiApp'. 140 | * 0.7.1 : Added 'showRouteQuery', renamed 'text' to 'plain', 'html' now accepts Text instead of ByteString 141 | * 0.7.0 : Subsites support added 142 | * 0.6.2 : Added 'maybeRoute' and 'routeAttrSet', to get information about the currently executing route 143 | * 0.6.1 : Fixed cabal and travis files 144 | * 0.6.0 : Removed dependency on yesod-routes. Updated code to compile with wai-3 and ghc-7.8, ghc-7.10 145 | * 0.5.1 : Bumped dependency upper bounds to allow text 1.* 146 | * 0.5.0 : Added raw,text,html,json helpers. Update to wai-2.1. 147 | * 0.4.1 : showRoute now returns "/" instead of "" 148 | * 0.4.0 : Wai 2 compatibility. Replaced 'liftResourceT' with 'lift' 149 | * 0.3.4 : Added 'liftResourceT' to lift a ResourceT into HandlerM 150 | * 0.3.3 : Better exports from the Network.Wai.Middleware.Routes module 151 | * 0.3.2 : Added HandlerM Monad which makes it easier to build Handlers 152 | * 0.3.1 : Removed internal 'App' synonym which only muddied the types. Added common content types for convenience. 153 | * 0.3.0 : yesod-routes 1.2 compatibility. Abstracted request data. Created `runNext` which skips to the next app in the wai stack 154 | * 0.2.4 : Put an upper bound on yesod-routes version as 1.2 breaks API compatibility 155 | * 0.2.3 : Implemented a better showRoute function. Added blaze-builder as a dependency 156 | * 0.2.2 : Fixed license information in hs and cabal files 157 | * 0.2.1 : Changed license to MIT 158 | * 0.2 : Updated functionality based on yesod-routes package 159 | * 0.1 : Intial release 160 | -------------------------------------------------------------------------------- /src/Routes/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter 4 | module Routes.Parse 5 | ( parseRoutes 6 | , parseRoutesFile 7 | , parseRoutesNoCheck 8 | , parseRoutesFileNoCheck 9 | , parseType 10 | , parseTypeTree 11 | , TypeTree (..) 12 | , dropBracket 13 | , nameToType 14 | , isTvar 15 | ) where 16 | 17 | import Language.Haskell.TH.Syntax 18 | import Data.Char (isUpper, isLower, isSpace) 19 | import Language.Haskell.TH.Quote 20 | import qualified System.IO as SIO 21 | import Routes.TH 22 | import Routes.Overlap (findOverlapNames) 23 | import Data.List (foldl', isPrefixOf) 24 | import Data.Maybe (mapMaybe) 25 | import qualified Data.Set as Set 26 | 27 | -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for 28 | -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the 29 | -- checking. See documentation site for details on syntax. 30 | parseRoutes :: QuasiQuoter 31 | parseRoutes = QuasiQuoter { quoteExp = x } 32 | where 33 | x s = do 34 | let res = resourcesFromString s 35 | case findOverlapNames res of 36 | [] -> lift res 37 | z -> error $ unlines $ "Overlapping routes: " : map show z 38 | 39 | -- | Same as 'parseRoutes', but uses an external file instead of quasiquotation. 40 | -- 41 | -- The recommended file extension is @.yesodroutes@. 42 | parseRoutesFile :: FilePath -> Q Exp 43 | parseRoutesFile = parseRoutesFileWith parseRoutes 44 | 45 | -- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation. 46 | -- 47 | -- The recommended file extension is @.yesodroutes@. 48 | parseRoutesFileNoCheck :: FilePath -> Q Exp 49 | parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck 50 | 51 | parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp 52 | parseRoutesFileWith qq fp = do 53 | qAddDependentFile fp 54 | s <- qRunIO $ readUtf8File fp 55 | quoteExp qq s 56 | 57 | readUtf8File :: FilePath -> IO String 58 | readUtf8File fp = do 59 | h <- SIO.openFile fp SIO.ReadMode 60 | SIO.hSetEncoding h SIO.utf8_bom 61 | SIO.hGetContents h 62 | 63 | -- | Same as 'parseRoutes', but performs no overlap checking. 64 | parseRoutesNoCheck :: QuasiQuoter 65 | parseRoutesNoCheck = QuasiQuoter 66 | { quoteExp = lift . resourcesFromString 67 | } 68 | 69 | -- | Converts a multi-line string to a set of resources. See documentation for 70 | -- the format of this string. This is a partial function which calls 'error' on 71 | -- invalid input. 72 | resourcesFromString :: String -> [ResourceTree String] 73 | resourcesFromString = 74 | fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r') 75 | where 76 | parse _ [] = ([], []) 77 | parse indent (thisLine:otherLines) 78 | | length spaces < indent = ([], thisLine : otherLines) 79 | | otherwise = (this others, remainder) 80 | where 81 | parseAttr ('!':x) = Just x 82 | parseAttr _ = Nothing 83 | 84 | stripColonLast = 85 | go id 86 | where 87 | go _ [] = Nothing 88 | go front [x] 89 | | null x = Nothing 90 | | last x == ':' = Just $ front [init x] 91 | | otherwise = Nothing 92 | go front (x:xs) = go (front . (x:)) xs 93 | 94 | spaces = takeWhile (== ' ') thisLine 95 | (others, remainder) = parse indent otherLines' 96 | (this, otherLines') = 97 | case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of 98 | (pattern:rest0) 99 | | Just (constr:rest) <- stripColonLast rest0 100 | , Just attrs <- mapM parseAttr rest -> 101 | let (children, otherLines'') = parse (length spaces + 1) otherLines 102 | children' = addAttrs attrs children 103 | (pieces, Nothing, check) = piecesFromStringCheck pattern 104 | in ((ResourceParent constr check pieces children' :), otherLines'') 105 | (pattern:constr:rest) -> 106 | let (pieces, mmulti, check) = piecesFromStringCheck pattern 107 | (attrs, rest') = takeAttrs rest 108 | disp = dispatchFromString rest' mmulti 109 | in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) 110 | [] -> (id, otherLines) 111 | _ -> error $ "Invalid resource line: " ++ thisLine 112 | 113 | -- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). 114 | splitSpaces :: String -> [String] 115 | splitSpaces "" = [] 116 | splitSpaces str = 117 | let (rest, piece) = parse $ dropWhile isSpace str in 118 | piece:(splitSpaces rest) 119 | 120 | where 121 | parse :: String -> ( String, String) 122 | parse ('{':s) = fmap ('{':) $ parseBracket s 123 | parse (c:s) | isSpace c = (s, []) 124 | parse (c:s) = fmap (c:) $ parse s 125 | parse "" = ("", "") 126 | 127 | parseBracket :: String -> ( String, String) 128 | parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str 129 | parseBracket ('}':s) = fmap ('}':) $ parse s 130 | parseBracket (c:s) = fmap (c:) $ parseBracket s 131 | parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str 132 | 133 | piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) 134 | piecesFromStringCheck s0 = 135 | (pieces, mmulti, check) 136 | where 137 | (s1, check1) = stripBang s0 138 | (pieces', mmulti') = piecesFromString $ drop1Slash s1 139 | pieces = map snd pieces' 140 | mmulti = fmap snd mmulti' 141 | check = check1 && all fst pieces' && maybe True fst mmulti' 142 | 143 | stripBang ('!':rest) = (rest, False) 144 | stripBang x = (x, True) 145 | 146 | addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String] 147 | addAttrs attrs = 148 | map goTree 149 | where 150 | goTree (ResourceLeaf res) = ResourceLeaf (goRes res) 151 | goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) 152 | 153 | goRes res = 154 | res { resourceAttrs = noDupes ++ resourceAttrs res } 155 | where 156 | usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res 157 | used attr = 158 | case toPair attr of 159 | Nothing -> False 160 | Just (key, _) -> key `Set.member` usedKeys 161 | noDupes = filter (not . used) attrs 162 | 163 | toPair s = 164 | case break (== '=') s of 165 | (x, '=':y) -> Just (x, y) 166 | _ -> Nothing 167 | 168 | -- | Take attributes out of the list and put them in the first slot in the 169 | -- result tuple. 170 | takeAttrs :: [String] -> ([String], [String]) 171 | takeAttrs = 172 | go id id 173 | where 174 | go x y [] = (x [], y []) 175 | go x y (('!':attr):rest) = go (x . (attr:)) y rest 176 | go x y (z:rest) = go x (y . (z:)) rest 177 | 178 | dispatchFromString :: [String] -> Maybe String -> Dispatch String 179 | dispatchFromString rest mmulti 180 | | null rest = Methods mmulti [] 181 | | all (all isUpper) rest = Methods mmulti rest 182 | dispatchFromString [subTyp, subFun] Nothing = 183 | Subsite subTyp subFun 184 | dispatchFromString [_, _] Just{} = 185 | error "Subsites cannot have a multipiece" 186 | dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest 187 | 188 | drop1Slash :: String -> String 189 | drop1Slash ('/':x) = x 190 | drop1Slash x = x 191 | 192 | piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) 193 | piecesFromString "" = ([], Nothing) 194 | piecesFromString x = 195 | case (this, rest) of 196 | (Left typ, ([], Nothing)) -> ([], Just typ) 197 | (Left _, _) -> error "Multipiece must be last piece" 198 | (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) 199 | where 200 | (y, z) = break (== '/') x 201 | this = pieceFromString y 202 | rest = piecesFromString $ drop 1 z 203 | 204 | parseType :: String -> Type 205 | parseType orig = 206 | maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig 207 | 208 | parseTypeTree :: String -> Maybe TypeTree 209 | parseTypeTree orig = 210 | toTypeTree pieces 211 | where 212 | pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig 213 | addDashes [] = [] 214 | addDashes (x:xs) = 215 | front $ addDashes xs 216 | where 217 | front rest 218 | | x `elem` "()[]" = '-' : x : '-' : rest 219 | | otherwise = x : rest 220 | splitOn c s = 221 | case y' of 222 | _:y -> x : splitOn c y 223 | [] -> [x] 224 | where 225 | (x, y') = break c s 226 | 227 | data TypeTree = TTTerm String 228 | | TTApp TypeTree TypeTree 229 | | TTList TypeTree 230 | deriving (Show, Eq) 231 | 232 | toTypeTree :: [String] -> Maybe TypeTree 233 | toTypeTree orig = do 234 | (x, []) <- gos orig 235 | return x 236 | where 237 | go [] = Nothing 238 | go ("(":xs) = do 239 | (x, rest) <- gos xs 240 | case rest of 241 | ")":rest' -> Just (x, rest') 242 | _ -> Nothing 243 | go ("[":xs) = do 244 | (x, rest) <- gos xs 245 | case rest of 246 | "]":rest' -> Just (TTList x, rest') 247 | _ -> Nothing 248 | go (x:xs) = Just (TTTerm x, xs) 249 | 250 | gos xs1 = do 251 | (t, xs2) <- go xs1 252 | (ts, xs3) <- gos' id xs2 253 | Just (foldl' TTApp t ts, xs3) 254 | 255 | gos' front [] = Just (front [], []) 256 | gos' front (x:xs) 257 | | x `elem` words ") ]" = Just (front [], x:xs) 258 | | otherwise = do 259 | (t, xs') <- go $ x:xs 260 | gos' (front . (t:)) xs' 261 | 262 | ttToType :: TypeTree -> Type 263 | ttToType (TTTerm s) = nameToType s 264 | ttToType (TTApp x y) = ttToType x `AppT` ttToType y 265 | ttToType (TTList t) = ListT `AppT` ttToType t 266 | 267 | nameToType :: String -> Type 268 | nameToType t = if isTvar t 269 | then VarT $ mkName t 270 | else ConT $ mkName t 271 | 272 | isTvar :: String -> Bool 273 | isTvar (h:_) = isLower h 274 | isTvar _ = False 275 | 276 | pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) 277 | pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) 278 | pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652 279 | pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x) 280 | 281 | pieceFromString ('*':'!':x) = Left (False, x) 282 | pieceFromString ('+':'!':x) = Left (False, x) 283 | 284 | pieceFromString ('!':'*':x) = Left (False, x) 285 | pieceFromString ('!':'+':x) = Left (False, x) 286 | 287 | pieceFromString ('*':x) = Left (True, x) 288 | pieceFromString ('+':x) = Left (True, x) 289 | 290 | pieceFromString ('!':x) = Right $ (False, Static x) 291 | pieceFromString x = Right $ (True, Static x) 292 | 293 | dropBracket :: String -> String 294 | dropBracket str@('{':x) = case break (== '}') x of 295 | (s, "}") -> s 296 | _ -> error $ "Unclosed bracket ('{'): " ++ str 297 | dropBracket x = x 298 | 299 | -- | If this line ends with a backslash, concatenate it together with the next line. 300 | -- 301 | -- @since 1.6.8 302 | lineContinuations :: String -> [String] -> [String] 303 | lineContinuations this [] = [this] 304 | lineContinuations this below@(next:rest) = case unsnoc this of 305 | Just (this', '\\') -> (this'++next):rest 306 | _ -> this:below 307 | where unsnoc s = if null s then Nothing else Just (init s, last s) 308 | -------------------------------------------------------------------------------- /src/Routes/Routes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 5 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE CPP #-} 8 | {- | 9 | Module : Routes.Routes 10 | Copyright : (c) Anupam Jain 2013 11 | License : MIT (see the file LICENSE) 12 | 13 | Maintainer : ajnsit@gmail.com 14 | Stability : experimental 15 | Portability : non-portable (uses ghc extensions) 16 | 17 | This package provides typesafe URLs for Wai applications. 18 | -} 19 | module Routes.Routes 20 | ( -- * Quasi Quoters 21 | parseRoutes -- | Parse Routes declared inline 22 | , parseRoutesFile -- | Parse routes declared in a file 23 | , parseRoutesNoCheck -- | Parse routes declared inline, without checking for overlaps 24 | , parseRoutesFileNoCheck -- | Parse routes declared in a file, without checking for overlaps 25 | 26 | -- * Template Haskell methods 27 | , mkRoute 28 | , mkRouteSub 29 | 30 | -- * Dispatch 31 | , routeDispatch 32 | , customRouteDispatch 33 | 34 | -- * URL rendering and parsing 35 | , showRoute 36 | , showRouteQuery 37 | , readRoute 38 | 39 | -- * Application Handlers 40 | , Handler 41 | , HandlerS 42 | 43 | -- * As of Wai 3, Application datatype now follows continuation passing style 44 | -- A `ResponseHandler` represents a continuation passed to the application 45 | , ResponseHandler 46 | 47 | -- * Generated Datatypes 48 | , Routable(..) -- | Used internally. However needs to be exported for TH to work. 49 | , RenderRoute(..) -- | A `RenderRoute` instance for your site datatype is automatically generated by `mkRoute` 50 | , ParseRoute(..) -- | A `ParseRoute` instance for your site datatype is automatically generated by `mkRoute` 51 | , RouteAttrs(..) -- | A `RouteAttrs` instance for your site datatype is automatically generated by `mkRoute` 52 | 53 | -- * Accessing Request Data 54 | , Env(..) 55 | , RequestData -- | An abstract representation of the request data. You can get the wai request object by using `waiReq` 56 | , waiReq -- | Extract the wai `Request` object from `RequestData` 57 | , nextApp -- | Extract the next Application in the stack 58 | , currentRoute -- | Extract the current `Route` from `RequestData` 59 | , runNext -- | Run the next application in the stack 60 | 61 | -- * Not exported outside wai-routes 62 | , runHandler 63 | , readQueryString 64 | ) 65 | where 66 | 67 | -- Wai 68 | import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..)) 69 | import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText) 70 | 71 | -- Routes 72 | import Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..)) 73 | import Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType) 74 | import Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler) 75 | 76 | -- Text and Bytestring 77 | import Data.ByteString (ByteString) 78 | import Data.Text (Text) 79 | import Data.Text.Encoding (encodeUtf8, decodeUtf8) 80 | import Blaze.ByteString.Builder (toByteString) 81 | 82 | -- TH 83 | import Language.Haskell.TH.Syntax 84 | 85 | -- Convenience 86 | import Control.Arrow (second) 87 | import Data.Maybe (fromMaybe) 88 | 89 | -- An abstract request 90 | data RequestData master = RequestData 91 | { waiReq :: Request 92 | , nextApp :: Application 93 | , currentRoute :: Maybe (Route master) 94 | } 95 | 96 | -- AJ: Experimental 97 | type ResponseHandler = (Response -> IO ResponseReceived) -> IO ResponseReceived 98 | 99 | -- Wai uses Application :: Wai.Request -> ResponseHandler 100 | -- However, instead of Request, we use RequestData which has more information 101 | type App master = RequestData master -> ResponseHandler 102 | 103 | data Env sub master = Env 104 | { envMaster :: master 105 | , envSub :: sub 106 | , envToMaster :: Route sub -> Route master 107 | } 108 | 109 | -- | Run the next application in the stack 110 | runNext :: App master 111 | runNext req = nextApp req $ waiReq req 112 | 113 | -- | A `Handler` generates an App from the master datatype 114 | type Handler sub = forall master. RenderRoute master => HandlerS sub master 115 | type HandlerS sub master = Env sub master -> App sub 116 | 117 | -- | Generates everything except actual dispatch 118 | mkRouteData :: String -> [ResourceTree String] -> Q [Dec] 119 | mkRouteData typName routes = do 120 | let typ = parseType typName 121 | let rname = mkName $ "_resources" ++ typName 122 | let resourceTrees = map (fmap parseType) routes 123 | eres <- lift routes 124 | let resourcesDec = 125 | [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) 126 | , FunD rname [Clause [] (NormalB eres) []] 127 | ] 128 | rinst <- mkRenderRouteInstance [] typ resourceTrees 129 | pinst <- mkParseRouteInstance [] typ resourceTrees 130 | ainst <- mkRouteAttrsInstance [] typ resourceTrees 131 | return $ concat [ [ainst] 132 | , [pinst] 133 | , resourcesDec 134 | , rinst 135 | ] 136 | 137 | instanceD :: Cxt -> Type -> [Dec] -> Dec 138 | #if MIN_VERSION_template_haskell(2,11,0) 139 | instanceD = InstanceD Nothing 140 | #else 141 | instanceD = InstanceD 142 | #endif 143 | 144 | -- | Generates a 'Routable' instance and dispatch function 145 | mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec] 146 | mkRouteDispatch typName routes = do 147 | let typ = parseType typName 148 | disp <- mkRouteDispatchClause routes 149 | return [instanceD [] 150 | (ConT ''Routable `AppT` typ `AppT` typ) 151 | [FunD (mkName "dispatcher") [disp]]] 152 | 153 | -- | Same as mkRouteDispatch but for subsites 154 | mkRouteSubDispatch :: String -> String -> [ResourceTree a] -> Q [Dec] 155 | mkRouteSubDispatch typName constraint routes = do 156 | let typ = parseType typName 157 | disp <- mkRouteDispatchClause routes 158 | master <- newName "master" 159 | -- We don't simply use parseType for GHC 7.8 (TH-2.9) compatibility 160 | -- ParseType only works on Type (not Pred) 161 | -- In GHC 7.10 (TH-2.10) onwards, Pred is aliased to Type 162 | className <- lookupTypeName constraint 163 | -- Check if this is a classname or a type 164 | let contract = maybe (error $ "Unknown typeclass " ++ show constraint) (getContract master) className 165 | return [instanceD [contract] 166 | (ConT ''Routable `AppT` typ `AppT` VarT master) 167 | [FunD (mkName "dispatcher") [disp]]] 168 | where 169 | getContract master className = 170 | #if MIN_VERSION_template_haskell(2,10,0) 171 | ConT className `AppT` VarT master 172 | #else 173 | ClassP className [VarT master] 174 | #endif 175 | 176 | -- Helper that creates the dispatch clause 177 | mkRouteDispatchClause :: [ResourceTree a] -> Q Clause 178 | mkRouteDispatchClause = 179 | mkDispatchClause MkDispatchSettings 180 | { mdsRunHandler = [| runHandler |] 181 | , mdsSubDispatcher = [| subDispatcher |] 182 | , mdsGetPathInfo = [| getPathInfo |] 183 | , mdsMethod = [| getReqMethod |] 184 | , mdsSetPathInfo = [| setPathInfo |] 185 | , mds404 = [| app404 |] 186 | , mds405 = [| app405 |] 187 | , mdsGetHandler = defaultGetHandler 188 | , mdsUnwrapper = return 189 | } 190 | 191 | 192 | -- | Generates all the things needed for efficient routing. 193 | -- Including your application's `Route` datatype, 194 | -- `RenderRoute`, `ParseRoute`, `RouteAttrs`, and `Routable` instances. 195 | -- Use this for everything except subsites 196 | mkRoute :: String -> [ResourceTree String] -> Q [Dec] 197 | mkRoute typName routes = do 198 | dat <- mkRouteData typName routes 199 | disp <- mkRouteDispatch typName routes 200 | return (disp++dat) 201 | 202 | -- TODO: Also allow using the master datatype name directly, instead of a constraint class 203 | -- | Same as mkRoute, but for subsites 204 | mkRouteSub :: String -> String -> [ResourceTree String] -> Q [Dec] 205 | mkRouteSub typName constraint routes = do 206 | dat <- mkRouteData typName routes 207 | disp <- mkRouteSubDispatch typName constraint routes 208 | return (disp++dat) 209 | 210 | -- | A `Routable` instance can be used in dispatching. 211 | -- An appropriate instance for your site datatype is 212 | -- automatically generated by `mkRoute`. 213 | class Routable sub master where 214 | dispatcher :: HandlerS sub master 215 | 216 | -- | Generates the application middleware from a `Routable` master datatype 217 | routeDispatch :: Routable master master => master -> Middleware 218 | routeDispatch = customRouteDispatch dispatcher 219 | 220 | -- | Like routeDispatch but generates the application middleware from a custom dispatcher 221 | customRouteDispatch :: HandlerS master master -> master -> Middleware 222 | -- TODO: Should this have master master instead of sub master? 223 | -- TODO: Verify that this plays well with subsites 224 | -- Env master master is converted to Env sub master by subDispatcher 225 | -- Route information is filled in by runHandler 226 | customRouteDispatch customDispatcher master def req = customDispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing} 227 | 228 | -- | Render a `Route` and Query parameters to Text 229 | showRouteQuery :: RenderRoute master => Route master -> [(Text,Text)] -> Text 230 | showRouteQuery r q = uncurry _encodePathInfo $ second (map (second Just) . (++ q)) $ renderRoute r 231 | 232 | -- | Renders a `Route` as Text 233 | showRoute :: RenderRoute master => Route master -> Text 234 | showRoute = uncurry _encodePathInfo . second (map $ second Just) . renderRoute 235 | 236 | _encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text 237 | -- Slightly hackish: Convert "" into "/" 238 | _encodePathInfo [] = _encodePathInfo [""] 239 | _encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery 240 | 241 | -- | Read a route from Text 242 | -- Returns Nothing if Route reading failed. Just route otherwise 243 | readRoute :: ParseRoute master => Text -> Maybe (Route master) 244 | readRoute = parseRoute . second readQueryString . decodePath . encodeUtf8 245 | 246 | -- | Convert a Query to the format expected by parseRoute 247 | readQueryString :: Query -> [(Text, Text)] 248 | readQueryString = map (second (fromMaybe "")) . queryToQueryText 249 | 250 | -- PRIVATE 251 | 252 | -- Get the request method from a RequestData 253 | getReqMethod :: RequestData master -> ByteString 254 | getReqMethod = requestMethod . waiReq 255 | 256 | -- Get the path info from a RequestData 257 | getPathInfo :: RequestData master -> [Text] 258 | getPathInfo = pathInfo . waiReq 259 | 260 | -- Set the path info in a RequestData 261 | setPathInfo :: [Text] -> RequestData master -> RequestData master 262 | setPathInfo p reqData = reqData { waiReq = (waiReq reqData){pathInfo=p} } 263 | 264 | -- Baked in applications that handle 404 and 405 errors 265 | -- On no matching route, skip to next application 266 | app404 :: HandlerS sub master 267 | app404 _master = runNext 268 | 269 | -- On matching route, but no matching http method, skip to next application 270 | -- This allows a later route to handle methods not implemented by the previous routes 271 | app405 :: HandlerS sub master 272 | app405 _master = runNext 273 | 274 | -- Run a route handler function 275 | -- Currently all this does is populate the route into RequestData 276 | -- But it may do more in the future 277 | runHandler 278 | :: HandlerS sub master 279 | -> Env sub master 280 | -> Maybe (Route sub) 281 | -> App sub 282 | runHandler h env route reqdata = h env reqdata{currentRoute=route} 283 | 284 | -- Run a route subsite handler function 285 | subDispatcher 286 | :: Routable sub master 287 | => (HandlerS sub master -> Env sub master -> Maybe (Route sub) -> App sub) 288 | -> (master -> sub) 289 | -> (Route sub -> Route master) 290 | -> Env master master 291 | -> App master 292 | subDispatcher _runhandler getSub toMasterRoute env reqData = dispatcher env' reqData' 293 | where 294 | env' = _envToSub getSub toMasterRoute env 295 | reqData' = reqData{currentRoute=Nothing} 296 | -- qq (k,mv) = (decodeUtf8 k, maybe "" decodeUtf8 mv) 297 | -- req = waiReq reqData 298 | 299 | _masterToEnv :: master -> Env master master 300 | _masterToEnv master = Env master master id 301 | 302 | _envToSub :: (master -> sub) -> (Route sub -> Route master) -> Env master master -> Env sub master 303 | _envToSub getSub toMasterRoute env = Env master sub toMasterRoute 304 | where 305 | master = envMaster env 306 | sub = getSub master 307 | -------------------------------------------------------------------------------- /src/Routes/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} 2 | {- | 3 | Module : Routes.Handler 4 | Copyright : (c) Anupam Jain 2013 5 | License : MIT (see the file LICENSE) 6 | 7 | Maintainer : ajnsit@gmail.com 8 | Stability : experimental 9 | Portability : non-portable (uses ghc extensions) 10 | 11 | Provides a HandlerM Monad that makes it easy to build Handlers 12 | -} 13 | module Routes.Handler 14 | ( HandlerM() -- | A Monad that makes it easier to build a Handler 15 | , runHandlerM -- | Run a HandlerM to get a Handler 16 | , mountedAppHandler -- | Convert a full wai application to a HandlerS 17 | , request -- | Access the request data 18 | , isWebsocket -- | Is this a websocket request 19 | , reqHeader -- | Get a particular request header (case insensitive) 20 | , reqHeaders -- | Get all request headers (case insensitive) 21 | , routeAttrSet -- | Access the route attribute list 22 | , rootRouteAttrSet -- | Access the route attribute list for the root route 23 | , maybeRoute -- | Access the route data 24 | , maybeRootRoute -- | Access the root route data 25 | , showRouteMaster -- | Get the route rendering function for the master site 26 | , showRouteSub -- | Get the route rendering function for the subsite 27 | , showRouteQueryMaster -- | Get the route + query params rendering function for the master site 28 | , showRouteQuerySub -- | Get the route + query params rendering function for the subsite 29 | , readRouteMaster -- | Get the route parsing function for the master site 30 | , readRouteSub -- | Get the route parsing function for the subsite 31 | , master -- | Access the master datatype 32 | , sub -- | Access the sub datatype 33 | , rawBody -- | Consume and return the request body as ByteString 34 | , textBody -- | Consume and return the request body as Text 35 | , jsonBody -- | Consume and return the request body as JSON 36 | , header -- | Add a header to the response 37 | , status -- | Set the response status 38 | , file -- | Send a file as response 39 | , filepart -- | Send a part of a file as response 40 | , stream -- | Stream a response 41 | , raw -- | Set the raw response body 42 | , rawBuilder -- | Set the raw response body as a ByteString Builder 43 | , json -- | Set the json response body 44 | , plain -- | Set the plain text response body 45 | , html -- | Set the html response body 46 | , css -- | Set the css response body 47 | , javascript -- | Set the javascript response body 48 | , content -- | Sets the response body when the content type is acceptable 49 | , asContent -- | Set the contentType and a 'Text' body 50 | , whenContent -- | Runs the action when a content type is acceptable 51 | , next -- | Run the next application in the stack 52 | , getParams -- | Get all params (query or post, not file) 53 | , getParam -- | Get a particular param (query or post, not file) 54 | , getQueryParams -- | Get all query params 55 | , getQueryParam -- | Get a particular query param 56 | , getPostParams -- | Get all post params 57 | , getPostParam -- | Get a particular post param 58 | , getFileParams -- | Get all file params 59 | , getFileParam -- | Get a particular file param 60 | , setCookie -- | Add a cookie to the response 61 | , getCookie -- | Get a cookie from the request 62 | , getCookies -- | Get all cookies from the request 63 | , reqVault -- | Access the vault from the request 64 | , lookupVault -- | Lookup a key in the request vault 65 | , updateVault -- | Update the request vault 66 | ) 67 | where 68 | 69 | import Network.Wai (Application, Request, responseRaw, responseFile, responseBuilder, responseStream, queryString, StreamingBody, requestHeaders, FilePart) 70 | #if MIN_VERSION_wai(3,0,1) 71 | import Network.Wai (strictRequestBody, vault) 72 | #endif 73 | import Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, showRoute, showRouteQuery, readRoute, readQueryString) 74 | import Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..)) 75 | import Routes.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll) 76 | 77 | import Control.Monad (liftM, when) 78 | import Control.Monad.Fail (MonadFail) 79 | import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, liftIO, MonadTrans) 80 | 81 | import Control.Arrow ((***)) 82 | import Control.Applicative (Applicative, (<$>), (<*>)) 83 | 84 | import qualified Control.Exception.Safe as EX 85 | import Data.Maybe (fromMaybe) 86 | import Data.ByteString (ByteString) 87 | import qualified Data.ByteString as B 88 | import qualified Data.ByteString.Lazy as BL 89 | import Blaze.ByteString.Builder (Builder, toByteString, fromByteString) 90 | import Network.HTTP.Types.Header (HeaderName(), RequestHeaders) 91 | import Network.HTTP.Types.Status (Status(), status200) 92 | 93 | import Data.Aeson (ToJSON, FromJSON, eitherDecodeStrict) 94 | 95 | import qualified Data.Aeson as A 96 | #if MIN_VERSION_aeson(0,10,0) 97 | #else 98 | import qualified Data.Aeson.Encode as AE 99 | #endif 100 | 101 | import Data.Set (Set) 102 | import qualified Data.Set as S (empty) 103 | 104 | import Data.Text (Text) 105 | import Data.Text.Encoding (encodeUtf8, decodeUtf8) 106 | 107 | import Data.CaseInsensitive (CI, mk) 108 | 109 | import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..)) 110 | import Data.List (intersect) 111 | 112 | import qualified Data.Vault.Lazy as V 113 | 114 | import qualified Network.Wai.Parse as P 115 | 116 | -- | The internal implementation of the HandlerM monad 117 | -- TODO: Should change this to StateT over ReaderT (but performance may suffer) 118 | newtype HandlerMI sub master m a = H { extractH :: StateT (HandlerState sub master) m a } 119 | deriving (Functor, Applicative, Monad, MonadFail, MonadIO, MonadTrans, MonadState (HandlerState sub master), EX.MonadThrow, EX.MonadCatch, EX.MonadMask) 120 | 121 | -- | The HandlerM Monad 122 | type HandlerM sub master = HandlerMI sub master IO 123 | 124 | -- | Modeled after Network.Wai.Parse.FileInfo, but uses Text for names, and lazy ByteString for content 125 | data FileInfo = FileInfo 126 | { fileName :: Text 127 | , fileContentType :: Text 128 | , fileContent :: BL.ByteString 129 | } 130 | 131 | -- Post Params 132 | -- Files are read into memory 133 | -- TODO: Check for security issues. Allow automatic storing of files on disk. 134 | type PostParams = ([(Text, Text)], [(Text, FileInfo)]) 135 | 136 | -- Private 137 | -- Convert from Network.Wai.Parse ([Param], [File y]) to PostParams 138 | _toPostParams :: ([P.Param], [P.File BL.ByteString]) -> PostParams 139 | _toPostParams (params, files) = (params', files') 140 | where 141 | params' = map (decodeUtf8 *** decodeUtf8) params 142 | files' = map (decodeUtf8 *** decodeFileInfo) files 143 | decodeFileInfo fi = FileInfo 144 | { fileName = decodeUtf8 $ P.fileName fi 145 | , fileContentType = decodeUtf8 $ P.fileContentType fi 146 | , fileContent = P.fileContent fi 147 | } 148 | 149 | -- A Raw Response handler :: source -> sink -> IO 150 | type RespRawHandler = IO B.ByteString -> (B.ByteString -> IO ()) -> IO () 151 | 152 | -- | The state kept in a HandlerM Monad 153 | data HandlerState sub master = HandlerState 154 | { getMaster :: master 155 | , getRequestData :: RequestData sub 156 | -- TODO: Experimental 157 | -- Streaming request body, consumed, and stored as a ByteString 158 | , reqBody :: Maybe ByteString 159 | , respHeaders :: [(HeaderName, ByteString)] 160 | , respStatus :: Status 161 | , respResp :: Maybe MkResponse 162 | , respRaw :: Maybe RespRawHandler 163 | , respCookies :: [SetCookie] 164 | , getSub :: sub 165 | , toMasterRoute :: Route sub -> Route master 166 | -- TODO: Experimental 167 | -- Parsed POST request body, in the same format as Network.Wai.Parse 168 | , postParams :: Maybe PostParams 169 | , acceptCTypes :: Maybe [ByteString] 170 | } 171 | 172 | -- Initial Handler State 173 | defaultHandlerState :: Env sub master -> RequestData sub -> HandlerState sub master 174 | defaultHandlerState env req = HandlerState 175 | { getMaster = envMaster env 176 | , getRequestData = req 177 | , reqBody = Nothing 178 | , respHeaders = [] 179 | , respStatus = status200 180 | , respResp = Nothing 181 | , respRaw = Nothing 182 | , respCookies = [] 183 | , getSub = envSub env 184 | , toMasterRoute = envToMaster env 185 | , postParams = Nothing 186 | , acceptCTypes = Nothing 187 | } 188 | 189 | -- Internal: Type of response 190 | -- Similar to Wai's Response type 191 | data MkResponse 192 | = ResponseFile FilePath (Maybe FilePart) 193 | | ResponseBuilder Builder 194 | | ResponseStream StreamingBody 195 | | ResponseNext 196 | 197 | -- Default response in case none is set by the handler 198 | defaultResponse :: MkResponse 199 | defaultResponse = ResponseBuilder "" 200 | 201 | -- The header name for request cookies 202 | cookieHeaderName :: CI ByteString 203 | cookieHeaderName = mk "Cookie" 204 | 205 | -- The header name for response cookies 206 | cookieSetHeaderName :: CI ByteString 207 | cookieSetHeaderName = mk "Set-Cookie" 208 | 209 | -- | Convert a full wai application to a Handler 210 | -- A bit like subsites, but at a higher level. 211 | mountedAppHandler :: Application -> HandlerS sub master 212 | mountedAppHandler app _env = app . waiReq 213 | 214 | -- | "Run" HandlerM, resulting in a Handler 215 | runHandlerM :: HandlerM sub master () -> HandlerS sub master 216 | runHandlerM h env req hh = do 217 | (_, st) <- runStateT (extractH h) (defaultHandlerState env req) 218 | -- Fetch the internal response structure 219 | let respData = fromMaybe defaultResponse (respResp st) 220 | -- Handle cookies (add them to headers) 221 | let headers' = map mkSetCookie (respCookies st) ++ respHeaders st 222 | -- Construct the actual wai response 223 | case mkResponse (respStatus st) headers' respData of 224 | -- Abort handling current response and move to next handler 225 | Nothing -> runNext (getRequestData st) hh 226 | -- Normal handling 227 | Just resp -> 228 | -- Check if we are trying to send a raw response 229 | case respRaw st of 230 | Nothing -> hh resp 231 | -- TODO: Ensure the body has not been read before using raw response 232 | Just rawHandler -> hh $ responseRaw rawHandler resp 233 | where 234 | mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s) 235 | mkResponse rstatus headers (ResponseFile path part) = Just $ responseFile rstatus headers path part 236 | mkResponse rstatus headers (ResponseBuilder builder) = Just $ responseBuilder rstatus headers builder 237 | mkResponse rstatus headers (ResponseStream streaming) = Just $ responseStream rstatus headers streaming 238 | mkResponse _ _ ResponseNext = Nothing 239 | 240 | -- | Get the request body as a bytestring. Consumes the entire body into memory at once. 241 | -- TODO: Implement streaming. Prevent clash with direct use of `Network.Wai.requestBody` 242 | rawBody :: HandlerM sub master ByteString 243 | rawBody = do 244 | s <- get 245 | case reqBody s of 246 | Just consumedBody -> return consumedBody 247 | Nothing -> do 248 | req <- request 249 | rbody <- liftIO $ BL.toStrict <$> _readStrictRequestBody req 250 | put s {reqBody = Just rbody} 251 | return rbody 252 | 253 | -- | Get the request body as a Text. However consumes the entire body at once. 254 | -- TODO: Implement streaming. Prevent clash with direct use of `Network.Wai.requestBody` 255 | textBody :: HandlerM master master Text 256 | textBody = liftM decodeUtf8 rawBody 257 | 258 | -- PRIVATE 259 | _readStrictRequestBody :: Request -> IO BL.ByteString 260 | _readStrictRequestBody = 261 | #if MIN_VERSION_wai(3,0,1) 262 | -- Use the `strictRequestBody` function available in wai > 3.0.1 263 | strictRequestBody 264 | #else 265 | -- Consume the entire body, and cache 266 | BL.fromChunks <$> unfoldWhileM (not . B.null) . requestBody 267 | #endif 268 | 269 | -- | Parse the body as a JSON object 270 | jsonBody :: FromJSON a => HandlerM sub master (Either String a) 271 | jsonBody = liftM eitherDecodeStrict rawBody 272 | 273 | -- | Get the master 274 | master :: HandlerM sub master master 275 | master = liftM getMaster get 276 | 277 | -- | Get the sub 278 | sub :: HandlerM sub master sub 279 | sub = liftM getSub get 280 | 281 | -- | Get the request 282 | request :: HandlerM sub master Request 283 | request = liftM (waiReq . getRequestData) get 284 | 285 | -- | Is this a websocket request 286 | isWebsocket :: HandlerM sub master Bool 287 | isWebsocket = liftM (maybe False (== "websocket")) (_reqHeaderBS "upgrade") 288 | 289 | -- | Get a particular request header (Case insensitive) 290 | reqHeader :: Text -> HandlerM sub master (Maybe Text) 291 | reqHeader name = liftM (fmap decodeUtf8) (_reqHeaderBS nameText) 292 | where 293 | nameText = mk $ encodeUtf8 name 294 | 295 | -- PRIVATE 296 | _reqHeaderBS :: CI ByteString -> HandlerM sub master (Maybe ByteString) 297 | _reqHeaderBS name = liftM (lookup name) reqHeaders 298 | 299 | -- VAULT 300 | -- | Access the vault 301 | reqVault :: HandlerM sub master V.Vault 302 | reqVault = liftM vault request 303 | 304 | -- Lookup a value in the request vault 305 | lookupVault :: V.Key a -> HandlerM sub master (Maybe a) 306 | lookupVault k = liftM (V.lookup k) reqVault 307 | 308 | -- Update the request vault 309 | -- For example: `updateVault (V.insert key val)` 310 | updateVault :: (V.Vault -> V.Vault) -> HandlerM sub master () 311 | updateVault f = modify $ \st -> 312 | let rd = getRequestData st 313 | r = waiReq rd 314 | v = f $ vault r 315 | in st { getRequestData = rd { waiReq = r { vault = v } } } 316 | -- END VAULT 317 | 318 | -- | Get all request headers as raw case-insensitive bytestrings 319 | reqHeaders :: HandlerM sub master RequestHeaders 320 | reqHeaders = liftM requestHeaders request 321 | 322 | -- | Get the current route 323 | maybeRoute :: HandlerM sub master (Maybe (Route sub)) 324 | maybeRoute = liftM (currentRoute . getRequestData) get 325 | 326 | -- | Get the current root route 327 | maybeRootRoute :: HandlerM sub master (Maybe (Route master)) 328 | maybeRootRoute = do 329 | s <- get 330 | return $ toMasterRoute s <$> currentRoute (getRequestData s) 331 | 332 | -- | Get the route rendering function for the master site 333 | showRouteMaster :: RenderRoute master => HandlerM sub master (Route master -> Text) 334 | showRouteMaster = return showRoute 335 | 336 | -- | Get the route rendering function for the subsite 337 | showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> Text) 338 | showRouteSub = do 339 | s <- get 340 | return $ showRoute . toMasterRoute s 341 | 342 | -- | Get the route rendering function for the master site 343 | showRouteQueryMaster :: RenderRoute master => HandlerM sub master (Route master -> [(Text,Text)] -> Text) 344 | showRouteQueryMaster = return showRouteQuery 345 | 346 | -- | Get the route rendering function for the subsite 347 | showRouteQuerySub :: RenderRoute master => HandlerM sub master (Route sub -> [(Text,Text)] -> Text) 348 | showRouteQuerySub = do 349 | s <- get 350 | return $ showRouteQuery . toMasterRoute s 351 | 352 | -- | Get the route parsing function for the master site 353 | readRouteMaster :: ParseRoute master => HandlerM sub master (Text -> Maybe (Route master)) 354 | readRouteMaster = return readRoute 355 | 356 | -- | Get the route parsing function for the subsite 357 | readRouteSub :: ParseRoute sub => HandlerM sub master (Text -> Maybe (Route master)) 358 | readRouteSub = do 359 | s <- get 360 | return $ (toMasterRoute s <$>) . readRoute 361 | 362 | -- | Get the current route attributes 363 | routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text) 364 | routeAttrSet = liftM (maybe S.empty routeAttrs . currentRoute . getRequestData) get 365 | 366 | -- | Get the attributes for the current root route 367 | rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text) 368 | rootRouteAttrSet = do 369 | s <- get 370 | return $ maybe S.empty (routeAttrs . toMasterRoute s) $ currentRoute $ getRequestData s 371 | 372 | -- | Add a header to the application response 373 | -- TODO: Differentiate between setting and adding headers 374 | header :: HeaderName -> ByteString -> HandlerM sub master () 375 | header h b = modify addHeader 376 | where 377 | addHeader :: HandlerState sub master -> HandlerState sub master 378 | addHeader st@(HandlerState {respHeaders=hs}) = st {respHeaders=(h,b):hs} 379 | 380 | -- | Set the response status 381 | status :: Status -> HandlerM sub master () 382 | status s = modify setStatus 383 | where 384 | setStatus :: HandlerState sub master -> HandlerState sub master 385 | setStatus st = st{respStatus=s} 386 | 387 | -- | Send a file as response 388 | file :: FilePath -> HandlerM sub master () 389 | file f = do 390 | header contentType $ contentTypeFromFile f 391 | modify addFile 392 | where 393 | addFile st = _setResp st $ ResponseFile f Nothing 394 | 395 | -- | Send a part of a file as response 396 | filepart :: FilePath -> FilePart -> HandlerM sub master () 397 | filepart f part = do 398 | header contentType $ contentTypeFromFile f 399 | modify addFile 400 | where 401 | addFile st = _setResp st $ ResponseFile f (Just part) 402 | 403 | -- | Stream the response 404 | stream :: StreamingBody -> HandlerM sub master () 405 | stream s = modify addStream 406 | where 407 | addStream st = _setResp st $ ResponseStream s 408 | 409 | -- | Set the response body 410 | raw :: ByteString -> HandlerM sub master () 411 | raw = rawBuilder . fromByteString 412 | 413 | -- | Set the response body as a builder 414 | rawBuilder :: Builder -> HandlerM sub master () 415 | rawBuilder b = modify addBody 416 | where 417 | addBody st = _setResp st $ ResponseBuilder b 418 | 419 | -- | Run the next application 420 | next :: HandlerM sub master () 421 | next = modify rNext 422 | where 423 | rNext st = _setResp st ResponseNext 424 | 425 | -- Util 426 | -- Set the response handler (don't overwrite an existing response) 427 | _setResp :: HandlerState sub master -> MkResponse -> HandlerState sub master 428 | _setResp st r = case respResp st of 429 | Nothing -> st{respResp=Just r} 430 | _ -> st 431 | 432 | 433 | -- Standard response bodies 434 | 435 | -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" 436 | -- header to \"application/json\". 437 | json :: ToJSON a => a -> HandlerM sub master () 438 | -- TODO: Use Accept header parsing 439 | -- json a = whenContent [typeJson, typeJavascript, typePlain] $ do 440 | json a = do 441 | header contentType typeJson 442 | rawBuilder $ _encode $ A.toJSON a 443 | where 444 | #if MIN_VERSION_aeson(0,10,0) 445 | _encode = A.fromEncoding . A.toEncoding 446 | #elif MIN_VERSION_aeson(0,9,0) 447 | _encode = AE.encodeToBuilder 448 | #else 449 | _encode = AE.encodeToByteStringBuilder 450 | #endif 451 | 452 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 453 | -- header to \"text/plain\". 454 | plain :: Text -> HandlerM sub master () 455 | -- TODO: Use Accept header parsing 456 | -- plain = content [typePlain] 457 | plain = asContent typePlain 458 | 459 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 460 | -- header to \"text/html\". 461 | html :: Text -> HandlerM sub master () 462 | -- TODO: Use Accept header parsing 463 | -- html = content [typeHtml, typePlain] 464 | html = asContent typeHtml 465 | 466 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 467 | -- header to \"text/css\". 468 | css :: Text -> HandlerM sub master () 469 | -- TODO: Use Accept header parsing 470 | -- css = content [typeCss, typePlain] 471 | css = asContent typeCss 472 | 473 | -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" 474 | -- header to \"text/javascript\". 475 | javascript :: Text -> HandlerM sub master () 476 | -- TODO: Use Accept header parsing 477 | -- javascript = content [typeJavascript, typePlain] 478 | javascript = asContent typeJavascript 479 | 480 | -- | Sets the content-type header to the given Bytestring 481 | -- (look in Routes.ContentTypes for examples) 482 | -- And sets the body of the response to the given Text 483 | asContent :: ByteString -> Text -> HandlerM sub master () 484 | asContent ctype s = do 485 | header contentType ctype 486 | raw $ encodeUtf8 s 487 | 488 | -- | Sets the response body when the content type is acceptable 489 | content :: [ByteString] -> Text -> HandlerM sub master () 490 | content [] _ = return () 491 | content ctypes s = whenContent ctypes (asContent (head ctypes) s) 492 | 493 | -- | Perform an action only when there is no accept list or the given contentType is acceptable 494 | whenContent :: [ByteString] -> HandlerM sub master () -> HandlerM sub master () 495 | whenContent ctypes respHandler = do 496 | atypes <- acceptableContentTypes 497 | let noAcceptList = not $ null atypes 498 | let acceptableTypeFound = not $ null $ intersect (typeAll:ctypes) atypes 499 | when (noAcceptList || acceptableTypeFound) respHandler 500 | 501 | -- | Get a list of content types acceptable to the request 502 | acceptableContentTypes :: HandlerM sub master [ByteString] 503 | acceptableContentTypes = do 504 | st <- get 505 | maybe (getCTypes st) return (acceptCTypes st) 506 | where 507 | getCTypes st = do 508 | h <- _reqHeaderBS acceptContentType 509 | let parsedCTypes = maybe [] P.parseHttpAccept h 510 | put st{acceptCTypes = Just parsedCTypes} 511 | return parsedCTypes 512 | 513 | -- | Sets a cookie to the response 514 | setCookie :: SetCookie -> HandlerM sub master () 515 | setCookie s = modify setCookie' 516 | where 517 | setCookie' st = st {respCookies = s : respCookies st} 518 | 519 | -- | Get all cookies 520 | getCookies :: HandlerM sub master CookiesText 521 | getCookies = do 522 | -- Note: We don't cache the parsedCookies for all requests to avoid overhead 523 | -- However it is pretty easy to cache cookies in the app itself 524 | cookies <- _reqHeaderBS cookieHeaderName 525 | return $ case cookies of 526 | Nothing -> [] 527 | Just cookies' -> parseCookiesText cookies' 528 | 529 | -- | Get a particular cookie 530 | getCookie :: Text -> HandlerM sub master (Maybe Text) 531 | getCookie name = do 532 | cookies <- getCookies 533 | return $ lookup name cookies 534 | 535 | -- PRIVATE 536 | -- Get the cached post params (if any) 537 | _getCachedPostParams :: HandlerM sub master (Maybe PostParams) 538 | _getCachedPostParams = postParams <$> get 539 | 540 | -- PRIVATE 541 | -- Util: Parse and cache post params 542 | _populatePostParams :: HandlerM sub master PostParams 543 | _populatePostParams = do 544 | st <- get 545 | case postParams st of 546 | Just params -> return params 547 | Nothing -> do 548 | req <- request 549 | params <- case P.getRequestBodyType req of 550 | Nothing -> return ([],[]) 551 | Just _ -> do 552 | -- TODO: Use cached request body instead of reading it from wai request 553 | params <- liftIO $ P.parseRequestBody P.lbsBackEnd req 554 | return $ _toPostParams params 555 | put $ st{postParams=Just params} 556 | return params 557 | 558 | -- PRIVATE 559 | -- Get a list of post parameters 560 | _getAllFileOrPostParams :: HandlerM sub master PostParams 561 | _getAllFileOrPostParams = do 562 | cachedPostParams <- _getCachedPostParams 563 | case cachedPostParams of 564 | Nothing -> _populatePostParams 565 | Just params -> return params 566 | 567 | -- | Get all Query params 568 | getQueryParams :: HandlerM sub master [(Text,Text)] 569 | getQueryParams = readQueryString . queryString <$> request 570 | 571 | -- | Get a particular Query param 572 | getQueryParam :: Text -> HandlerM sub master (Maybe Text) 573 | getQueryParam name = lookup name <$> getQueryParams 574 | 575 | -- | Get all Post params 576 | getPostParams :: HandlerM sub master [(Text,Text)] 577 | getPostParams = do 578 | (params,_) <- _getAllFileOrPostParams 579 | return params 580 | 581 | -- | Get a particular Post param 582 | getPostParam :: Text -> HandlerM sub master (Maybe Text) 583 | getPostParam name = lookup name <$> getPostParams 584 | 585 | -- | Get all File params 586 | getFileParams :: HandlerM sub master [(Text,FileInfo)] 587 | getFileParams = do 588 | (_,files) <- _getAllFileOrPostParams 589 | return files 590 | 591 | -- | Get a particular File param 592 | getFileParam :: Text -> HandlerM sub master (Maybe FileInfo) 593 | getFileParam name = lookup name <$> getFileParams 594 | 595 | -- | Get all params (query or post, NOT file) 596 | -- Duplicate parameters are preserved 597 | getParams :: HandlerM sub master [(Text, Text)] 598 | getParams = (++) <$> getQueryParams <*> getPostParams 599 | 600 | -- | Get a param (query or post, NOT file) 601 | getParam :: Text -> HandlerM sub master (Maybe Text) 602 | getParam name = do 603 | getLookup <- getQueryParam name 604 | case getLookup of 605 | Nothing -> getPostParam name 606 | Just _ -> return getLookup 607 | --------------------------------------------------------------------------------