├── .gitignore ├── servant-router ├── Setup.hs ├── shell.nix ├── stack.yaml ├── default.nix ├── test │ └── Spec.hs ├── LICENSE ├── servant-router.cabal └── src │ └── Servant │ └── Router.hs ├── examples ├── reflex │ ├── stack.yaml │ ├── shell.nix │ ├── default.nix │ ├── reflex-example.cabal │ └── src │ │ └── ReflexTest.hs └── server │ ├── stack.yaml │ ├── shell.nix │ ├── default.nix │ ├── server-example.cabal │ └── src │ └── Server.hs ├── reflex-platform.nix ├── README.md ├── callHackageFix.nix └── default.nix /.gitignore: -------------------------------------------------------------------------------- 1 | **/.stack-work 2 | **/result 3 | -------------------------------------------------------------------------------- /servant-router/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/reflex/stack.yaml: -------------------------------------------------------------------------------- 1 | nix: 2 | enable: true 3 | shell-file: shell.nix 4 | packages: [] 5 | resolver: ghc-8.0.1 # Doesn't matter. We're ignoring it. 6 | packages: 7 | - '.' 8 | -------------------------------------------------------------------------------- /examples/server/stack.yaml: -------------------------------------------------------------------------------- 1 | nix: 2 | enable: true 3 | shell-file: shell.nix 4 | packages: [] 5 | resolver: ghc-8.0.1 # Doesn't matter. We're ignoring it. 6 | packages: 7 | - '.' 8 | -------------------------------------------------------------------------------- /servant-router/shell.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ./. args).env 7 | -------------------------------------------------------------------------------- /servant-router/stack.yaml: -------------------------------------------------------------------------------- 1 | nix: 2 | enable: true 3 | shell-file: shell.nix 4 | packages: [] 5 | resolver: ghc-8.0.1 # Doesn't matter. We're ignoring it. 6 | packages: 7 | - '.' 8 | -------------------------------------------------------------------------------- /examples/reflex/shell.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ./. args).env 7 | -------------------------------------------------------------------------------- /examples/server/shell.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ./. args).env 7 | -------------------------------------------------------------------------------- /servant-router/default.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ../. args).servant-router 7 | -------------------------------------------------------------------------------- /examples/reflex/default.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ../../. args).reflex-example 7 | -------------------------------------------------------------------------------- /examples/server/default.nix: -------------------------------------------------------------------------------- 1 | { reflex ? import ./reflex-platform.nix {} 2 | , env ? "ghc" 3 | , ghc ? null # Stack gives us this. We don't care 4 | } @ args: 5 | 6 | (import ../../. args).server-example 7 | -------------------------------------------------------------------------------- /reflex-platform.nix: -------------------------------------------------------------------------------- 1 | import ((import {}).fetchFromGitHub { 2 | owner = "reflex-frp"; 3 | repo = "reflex-platform"; 4 | rev = "824e979768798ae9089cffdf54548c34fe391648"; 5 | sha256 = "0wd3avk6ygbx782bd560k7ba3h9579nvb67rbb4qj984mdbp555g"; 6 | }) 7 | -------------------------------------------------------------------------------- /examples/server/server-example.cabal: -------------------------------------------------------------------------------- 1 | name: server-example 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable server-example 7 | hs-source-dirs: src 8 | main-is: Server.hs 9 | build-depends: base 10 | , servant-router 11 | , servant-server 12 | , servant-blaze 13 | , warp 14 | , blaze-html 15 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /examples/reflex/reflex-example.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-example 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable reflex-example 7 | hs-source-dirs: src 8 | main-is: ReflexTest.hs 9 | build-depends: base 10 | , servant-router 11 | , servant 12 | , reflex-dom 13 | , reflex-dom-contrib 14 | , text 15 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | servant-router 2 | --- 3 | 4 | `servant-router` routes a URI given a Servant API and an appropriate 5 | handler. In web applications, this is used to make single page 6 | applications (SPAs) with front-end routing, letting you share portions 7 | of your Servant APIs between the client and server. 8 | 9 | `servant-router` does not depend on `reflex` or any GHCJS packages. 10 | It's intended to be a general purpose URI router on any platform. 11 | Combined with `reflex-dom`, `servant-reflex`, and 12 | `reflex-dom-contrib`, this makes for a very satisfactory front-end 13 | Haskell experience. 14 | 15 | You can see examples of using `servant-router` on both the frontend 16 | and the backend in the `examples` directory. 17 | -------------------------------------------------------------------------------- /examples/server/src/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Data.Proxy 6 | import Network.Wai.Handler.Warp 7 | import Servant 8 | import Servant.HTML.Blaze 9 | import Servant.Router 10 | import Text.Blaze.Html5 as H hiding (main) 11 | import Text.Blaze.Html5.Attributes 12 | import System.Environment 13 | 14 | type Views = "books" :> Capture "id" Int :> View 15 | :<|> "search" :> QueryParam "query" String :> View 16 | views :: Proxy Views 17 | views = Proxy 18 | 19 | type Api = "api" :> "books" :> Get '[JSON] [String] 20 | :<|> Raw 21 | api :: Proxy Api 22 | api = Proxy 23 | 24 | type WholeServer = ViewTransform Views (Get '[HTML] Html) 25 | :<|> Api 26 | wholeServer :: Proxy WholeServer 27 | wholeServer = Proxy 28 | 29 | server :: FilePath -> Server WholeServer 30 | server appDir = viewServer :<|> apiServer :<|> serveDirectoryFileServer appDir 31 | where 32 | apiServer = return ["Book Title!"] 33 | viewServer = constHandler views (Proxy :: Proxy Handler) $ docTypeHtml $ do 34 | H.head $ do 35 | script ! src "/all.js" $ return () 36 | return () 37 | body $ script ! src "/runmain.js" $ return () 38 | 39 | main :: IO () 40 | main = do 41 | (appDir:_) <- getArgs 42 | run 8080 $ serve wholeServer (server appDir) 43 | -------------------------------------------------------------------------------- /servant-router/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | import Data.ByteString (ByteString) 7 | import Data.Foldable 8 | import Data.Proxy 9 | import Servant.API 10 | import Servant.Router 11 | import URI.ByteString 12 | 13 | type TestApi = "root" :> Capture "cap" Int :> QueryParam "param" String :> View 14 | :<|> "other" :> Capture "othercap" String :> View 15 | testApi :: Proxy TestApi 16 | testApi = Proxy 17 | 18 | testUris :: [ByteString] 19 | testUris = 20 | [ "https://test.com/root/4?param=hi" 21 | , "https://test.com/other/hi/" 22 | , "/other/relativeMatch" 23 | , "https://test.com/fail" 24 | , "https://test.com/root/fail" 25 | , "/root/relativeFail" 26 | ] 27 | 28 | main :: IO () 29 | main = do 30 | let root :: Int -> Maybe String -> IO () 31 | root i s = print (i, s) 32 | other :: String -> IO () 33 | other = print 34 | for_ testUris $ \uri -> do 35 | result <- sequence $ withURI strictURIParserOptions uri $ \x -> 36 | routeURI testApi (root :<|> other) x 37 | print result 38 | 39 | -- TODO: Maybe open a pull request with this on uri-bytestring? 40 | withURI :: URIParserOptions -> ByteString -> (forall a . URIRef a -> b) -> Either URIParseError b 41 | withURI opts str f = case parseRelativeRef opts str of 42 | Right x -> Right (f x) 43 | Left _ -> f <$> parseURI opts str 44 | -------------------------------------------------------------------------------- /servant-router/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Will Fancher (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Will Fancher nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /servant-router/servant-router.cabal: -------------------------------------------------------------------------------- 1 | name: servant-router 2 | version: 0.10.0 3 | synopsis: Servant router for non-server applications. 4 | description: Write Servant APIs to be routed without a server. 5 | homepage: https://github.com/ElvishJerricco/servant-router 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Will Fancher 9 | maintainer: willfancher38@gmail.com 10 | copyright: 2016 Will Fancher 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Servant.Router 19 | build-depends: base >= 4.8 && < 5 20 | , servant >= 0.7 && < 0.11 21 | , text == 1.2.* 22 | , http-api-data >= 0.2 && < 0.4 23 | , http-types == 0.9.* 24 | , uri-bytestring == 0.2.* 25 | , bytestring == 0.10.* 26 | default-language: Haskell2010 27 | ghc-options: -Wall 28 | 29 | test-suite servant-router-test 30 | type: exitcode-stdio-1.0 31 | hs-source-dirs: test 32 | main-is: Spec.hs 33 | build-depends: base 34 | , servant-router 35 | , servant 36 | , bytestring 37 | , uri-bytestring 38 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 39 | default-language: Haskell2010 40 | 41 | source-repository head 42 | type: git 43 | location: https://github.com/ElvishJerricco/servant-router 44 | -------------------------------------------------------------------------------- /examples/reflex/src/ReflexTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RecursiveDo #-} 6 | 7 | module Main where 8 | 9 | import Data.Monoid 10 | import Data.Proxy 11 | import qualified Data.Text as Text 12 | import Reflex.Dom 13 | import Reflex.Dom.Contrib.Router 14 | import Servant.API hiding (URI) 15 | import Servant.Router 16 | 17 | type MyApi = "books" :> Capture "id" Int :> View 18 | :<|> "search" :> QueryParam "query" String :> View 19 | myApi :: Proxy MyApi 20 | myApi = Proxy 21 | 22 | main :: IO () 23 | main = mainWidget widget 24 | 25 | widget :: forall t m . MonadWidget t m => m () 26 | widget = do 27 | let handler :: RouteT MyApi m (Event t URI) 28 | handler = books :<|> search 29 | books i = do 30 | -- Here, you would get and display a book. 31 | -- Return a Reflex event for changing the browser location. 32 | el "div" $ text $ "Book: " <> Text.pack (show i) 33 | return never 34 | search Nothing = do 35 | -- Here, you would display a search bar. 36 | el "div" $ text "You searched nothing" 37 | return never 38 | search (Just keywords) = do 39 | -- Here you would display the search bar plus results. 40 | el "div" $ text $ "You searched: " <> Text.pack keywords 41 | return never 42 | -- Use reflex-dom-contrib for handling the address bar. 43 | routeHandler = route' (\_ uri -> uri) (routeURI myApi handler) 44 | 45 | rec dynamicRoute <- routeHandler (switch (current changeRoute)) 46 | routeWasSet <- dyn dynamicRoute -- Will fire on postbuild 47 | changeRoute <- holdDyn never $ fmap (either (const never) id) routeWasSet 48 | return () 49 | -------------------------------------------------------------------------------- /callHackageFix.nix: -------------------------------------------------------------------------------- 1 | # Reflex platform is using a very outdated nixpkgs, and updating would 2 | # be pretty nontrivial. To use `callHackage` to bump packages to newer 3 | # versions, we have to update `all-cabal-hashes`. I tried doing this 4 | # in the `packageOverrides` to `nixpkgsFunc` in `reflex-platform`, but 5 | # `haskellPackages` didn't seem to notice the difference, and used the 6 | # old `all-cabal-hashes` anyway. So here we just redefine 7 | # `callHackage` to use our own. 8 | 9 | pkgs: haskellPackages: 10 | 11 | let 12 | all-cabal-hashes = pkgs.fetchFromGitHub { 13 | owner = "commercialhaskell"; 14 | repo = "all-cabal-hashes"; 15 | rev = "a60545d2dc8177b1de1629e1f9119235822d5b83"; 16 | sha256 = "12szn4fckrxgzxdvlgks536lmxkahqmmnikla4vi5mlc494bbvml"; 17 | }; 18 | 19 | haskellSrc2nix = { name, src, sha256 ? null }: 20 | let 21 | sha256Arg = if isNull sha256 then "--sha256=" else ''--sha256="${sha256}"''; 22 | in pkgs.stdenv.mkDerivation { 23 | name = "cabal2nix-${name}"; 24 | buildInputs = [ pkgs.cabal2nix ]; 25 | phases = ["installPhase"]; 26 | LANG = "en_US.UTF-8"; 27 | LOCALE_ARCHIVE = pkgs.lib.optionalString pkgs.stdenv.isLinux "${pkgs.glibcLocales}/lib/locale/locale-archive"; 28 | installPhase = '' 29 | export HOME="$TMP" 30 | mkdir -p "$out" 31 | cabal2nix --compiler=${haskellPackages.ghc.name} --system=${pkgs.stdenv.system} ${sha256Arg} "${src}" > "$out/default.nix" 32 | ''; 33 | }; 34 | 35 | hackage2nix = name: version: haskellSrc2nix { 36 | name = "${name}-${version}"; 37 | sha256 = ''$(sed -e 's/.*"SHA256":"//' -e 's/".*$//' "${all-cabal-hashes}/${name}/${version}/${name}.json")''; 38 | src = "${all-cabal-hashes}/${name}/${version}/${name}.cabal"; 39 | }; 40 | 41 | in name: version: haskellPackages.callPackage (hackage2nix name version) 42 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | # This file overrides Reflex's haskellPackages, adding all the packages we need. 2 | # This includes bumping some dependencies. 3 | # Import this to get a haskellPackages with all the targets in this project. 4 | 5 | { reflex ? import ./reflex-platform.nix {} 6 | , env ? "ghc" 7 | , ghc ? null # Stack gives us this. We don't care 8 | }: 9 | 10 | reflex.${env}.override { 11 | overrides = self: super: 12 | let 13 | pkgs = reflex.nixpkgs; 14 | hlib = pkgs.haskell.lib; 15 | justCabal = builtins.filterSource (path: type: pkgs.lib.hasSuffix ".cabal" path); 16 | # `cabal2NixResult` copies your entire source directory to get 17 | # the cabal file. This is undesirable because it means 18 | # rebuilding that derivation whenever anything changes, rather 19 | # than just when the cabal file changes. In Nix, this isn't 20 | # usually a problem, even if it pollutes your nix store a 21 | # bit. But Intero freaks out when it sees the unexpected 22 | # "building cabal2nixResult" output. This function isolates just 23 | # the cabal files in the source directory. 24 | justCabalResult = s: reflex.cabal2nixResult (justCabal s); 25 | # After isolating the cabal file, override the resulting 26 | # derivation to set the `src` to the local source directory, but 27 | # also filter out unwanted paths. 28 | local = s: hlib.overrideCabal (self.callPackage (justCabalResult s) {}) (drv: { 29 | src = builtins.filterSource (path: type: 30 | type != "unknown" 31 | && baseNameOf path != ".git" 32 | && baseNameOf path != "result" 33 | && baseNameOf path != "dist" 34 | && baseNameOf path != ".stack-work") s; 35 | }); 36 | in { 37 | # Fix callHackage's out of date `all-cabal-hashes`. 38 | callHackage = import ./callHackageFix.nix pkgs self; 39 | 40 | # Bump `reflex-dom-contrib` from GitHub. 41 | reflex-dom-contrib = self.callPackage (pkgs.fetchFromGitHub { 42 | owner = "reflex-frp"; 43 | repo = "reflex-dom-contrib"; 44 | rev = "df4138406a5489acd72cf6c9e88988f13da02b31"; 45 | sha256 = "051x79afwzfbjv38z348pysnz49nmqg1czywd2s1sigvsdkg0gp9"; 46 | }) {}; 47 | 48 | # Bump dependencies. 49 | http-api-data = hlib.dontCheck (self.callHackage "http-api-data" "0.3.5" {}); 50 | natural-transformation = self.callHackage "natural-transformation" "0.4" {}; 51 | 52 | servant = self.callHackage "servant" "0.10" {}; 53 | servant-server = hlib.dontCheck (self.callHackage "servant-server" "0.10" {}); 54 | servant-blaze = self.callHackage "servant-blaze" "0.7.1" {}; 55 | 56 | # Set the locally defined packages. 57 | servant-router = local ./servant-router; 58 | server-example = local ./examples/server; 59 | reflex-example = local ./examples/reflex; 60 | }; 61 | } 62 | -------------------------------------------------------------------------------- /servant-router/src/Servant/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | module Servant.Router where 13 | 14 | import qualified Data.ByteString.Char8 as BS 15 | import Data.Proxy 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import Data.Text.Encoding 19 | import GHC.TypeLits 20 | import Network.HTTP.Types (decodePathSegments) 21 | import Servant.API hiding (URI(..)) 22 | import URI.ByteString 23 | import Web.HttpApiData 24 | 25 | -- | Router terminator. 26 | -- The 'HasRouter' instance for 'View' finalizes the router. 27 | -- 28 | -- Example: 29 | -- 30 | -- > type MyApi = "books" :> Capture "bookId" Int :> View 31 | data View 32 | 33 | instance HasLink View where 34 | type MkLink View = MkLink (Get '[] ()) 35 | toLink _ = toLink (Proxy :: Proxy (Get '[] ())) 36 | 37 | -- | When routing, the router may fail to match a location. 38 | -- Either this is an unrecoverable failure, 39 | -- such as failing to parse a query parameter, 40 | -- or it is recoverable by trying another path. 41 | data RoutingError = Fail | FailFatal deriving (Show, Eq, Ord) 42 | 43 | -- | A 'Router' contains the information necessary to execute a handler. 44 | data Router m a where 45 | RChoice :: Router m a -> Router m a -> Router m a 46 | RCapture :: FromHttpApiData x => (x -> Router m a) -> Router m a 47 | RQueryParam :: (FromHttpApiData x, KnownSymbol sym) 48 | => Proxy sym -> (Maybe x -> Router m a) -> Router m a 49 | RQueryParams :: (FromHttpApiData x, KnownSymbol sym) 50 | => Proxy sym -> ([x] -> Router m a) -> Router m a 51 | RQueryFlag :: KnownSymbol sym 52 | => Proxy sym -> (Bool -> Router m a) -> Router m a 53 | RPath :: KnownSymbol sym => Proxy sym -> Router m a -> Router m a 54 | RPage :: m a -> Router m a 55 | 56 | -- | Transform a layout by replacing 'View' with another type 57 | type family ViewTransform layout view where 58 | ViewTransform (a :<|> b) view = ViewTransform a view :<|> ViewTransform b view 59 | ViewTransform (a :> b) view = a :> ViewTransform b view 60 | ViewTransform View view = view 61 | 62 | -- | This is similar to the @HasServer@ class from @servant-server@. 63 | -- It is the class responsible for making API combinators routable. 64 | -- 'RuoteT' is used to build up the handler types. 65 | -- 'Router' is returned, to be interpretted by 'routeLoc'. 66 | class HasRouter layout where 67 | -- | A route handler. 68 | type RouteT layout (m :: * -> *) a :: * 69 | -- | Create a constant route handler that returns @a@ 70 | constHandler :: Monad m => Proxy layout -> Proxy m -> a -> RouteT layout m a 71 | -- | Transform a route handler into a 'Router'. 72 | route :: Proxy layout -> Proxy m -> Proxy a -> RouteT layout m a -> Router m a 73 | -- | Create a 'Router' from a constant. 74 | routeConst :: Monad m => Proxy layout -> Proxy m -> a -> Router m a 75 | routeConst l m a = route l m (Proxy :: Proxy a) (constHandler l m a) 76 | 77 | instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where 78 | type RouteT (x :<|> y) m a = RouteT x m a :<|> RouteT y m a 79 | constHandler _ m a = constHandler (Proxy :: Proxy x) m a 80 | :<|> constHandler (Proxy :: Proxy y) m a 81 | route 82 | _ 83 | (m :: Proxy m) 84 | (a :: Proxy a) 85 | ((x :: RouteT x m a) :<|> (y :: RouteT y m a)) 86 | = RChoice (route (Proxy :: Proxy x) m a x) (route (Proxy :: Proxy y) m a y) 87 | 88 | instance (HasRouter sublayout, FromHttpApiData x) 89 | => HasRouter (Capture sym x :> sublayout) where 90 | type RouteT (Capture sym x :> sublayout) m a = x -> RouteT sublayout m a 91 | constHandler _ m a _ = constHandler (Proxy :: Proxy sublayout) m a 92 | route _ m a f = RCapture (route (Proxy :: Proxy sublayout) m a . f) 93 | 94 | instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) 95 | => HasRouter (QueryParam sym x :> sublayout) where 96 | type RouteT (QueryParam sym x :> sublayout) m a 97 | = Maybe x -> RouteT sublayout m a 98 | constHandler _ m a _ = constHandler (Proxy :: Proxy sublayout) m a 99 | route _ m a f = RQueryParam 100 | (Proxy :: Proxy sym) 101 | (route (Proxy :: Proxy sublayout) m a . f) 102 | 103 | instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) 104 | => HasRouter (QueryParams sym x :> sublayout) where 105 | type RouteT (QueryParams sym x :> sublayout) m a = [x] -> RouteT sublayout m a 106 | constHandler _ m a _ = constHandler (Proxy :: Proxy sublayout) m a 107 | route _ m a f = RQueryParams 108 | (Proxy :: Proxy sym) 109 | (route (Proxy :: Proxy sublayout) m a . f) 110 | 111 | instance (HasRouter sublayout, KnownSymbol sym) 112 | => HasRouter (QueryFlag sym :> sublayout) where 113 | type RouteT (QueryFlag sym :> sublayout) m a = Bool -> RouteT sublayout m a 114 | constHandler _ m a _ = constHandler (Proxy :: Proxy sublayout) m a 115 | route _ m a f = RQueryFlag 116 | (Proxy :: Proxy sym) 117 | (route (Proxy :: Proxy sublayout) m a . f) 118 | 119 | instance (HasRouter sublayout, KnownSymbol path) 120 | => HasRouter (path :> sublayout) where 121 | type RouteT (path :> sublayout) m a = RouteT sublayout m a 122 | constHandler _ = constHandler (Proxy :: Proxy sublayout) 123 | route _ m a page = RPath 124 | (Proxy :: Proxy path) 125 | (route (Proxy :: Proxy sublayout) m a page) 126 | 127 | instance HasRouter View where 128 | type RouteT View m a = m a 129 | constHandler _ _ = return 130 | route _ _ _ = RPage 131 | 132 | -- | Use a handler to route a 'URIRef'. 133 | routeURI 134 | :: (HasRouter layout, Monad m) 135 | => Proxy layout 136 | -> RouteT layout m a 137 | -> URIRef uri 138 | -> m (Either RoutingError a) 139 | routeURI layout page uri = 140 | let routing = route layout Proxy Proxy page 141 | toMaybeQuery (k, v) = if BS.null v then (k, Nothing) else (k, Just v) 142 | 143 | (path, query) = case uri of 144 | URI{} -> (uriPath uri, uriQuery uri) 145 | RelativeRef{} -> (rrPath uri, rrQuery uri) 146 | in routeQueryAndPath (toMaybeQuery <$> queryPairs query) (decodePathSegments path) routing 147 | 148 | -- | Use a computed 'Router' to route a path and query. Generally, 149 | -- you should use 'routeURI'. 150 | routeQueryAndPath 151 | :: Monad m 152 | => [(BS.ByteString, Maybe BS.ByteString)] 153 | -> [Text] 154 | -> Router m a 155 | -> m (Either RoutingError a) 156 | routeQueryAndPath queries pathSegs r = case r of 157 | RChoice a b -> do 158 | result <- routeQueryAndPath queries pathSegs a 159 | case result of 160 | Left Fail -> routeQueryAndPath queries pathSegs b 161 | Left FailFatal -> return $ Left FailFatal 162 | Right x -> return $ Right x 163 | RCapture f -> case pathSegs of 164 | [] -> return $ Left Fail 165 | capture:paths -> 166 | maybe (return $ Left FailFatal) 167 | (routeQueryAndPath queries paths) 168 | (f <$> parseUrlPieceMaybe capture) 169 | RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) queries of 170 | Nothing -> routeQueryAndPath queries pathSegs $ f Nothing 171 | Just Nothing -> return $ Left FailFatal 172 | Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of 173 | Nothing -> return $ Left FailFatal 174 | Just x -> routeQueryAndPath queries pathSegs $ f (Just x) 175 | RQueryParams sym f -> 176 | maybe (return $ Left FailFatal) (routeQueryAndPath queries pathSegs . f) $ do 177 | ps <- sequence $ snd <$> filter (\(k, _) -> k == BS.pack (symbolVal sym)) queries 178 | sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps 179 | RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) queries of 180 | Nothing -> routeQueryAndPath queries pathSegs $ f False 181 | Just Nothing -> routeQueryAndPath queries pathSegs $ f True 182 | Just (Just _) -> return $ Left FailFatal 183 | RPath sym a -> case pathSegs of 184 | [] -> return $ Left Fail 185 | p:paths -> 186 | if p == T.pack (symbolVal sym) then routeQueryAndPath queries paths a else return $ Left Fail 187 | RPage a -> case pathSegs of 188 | [] -> Right <$> a 189 | _ -> return $ Left Fail 190 | --------------------------------------------------------------------------------