webcrank-dispatch (empty) → 0.1

raw patch · 13 files changed

+511/−0 lines, 13 filesdep +basedep +bytestringdep +mtlsetup-changed

Dependencies added: base, bytestring, mtl, path-pieces, reroute, text, unordered-containers

Files

• .ghci +2/−0
• .gitignore +2/−0
• .travis.yml +34/−0
• HLint.hs +5/−0
• LICENSE +25/−0
• README.md +100/−0
• Setup.hs +5/−0
• examples/LICENSE +30/−0
• examples/Main.hs +68/−0
• examples/Setup.hs +5/−0
• examples/webcrank-dispatch-examples.cabal +18/−0
• src/Webcrank/Dispatch.hs +172/−0
• webcrank-dispatch.cabal +45/−0

@@ -0,0 +1,2 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h+

@@ -0,0 +1,2 @@+dist+examples/dist

@@ -0,0 +1,34 @@+env:+ - GHCVER=7.6.1+ - GHCVER=7.6.2+ - GHCVER=7.6.3+ - GHCVER=7.8.3+ - GHCVER=7.8.4++before_install:+ - sudo add-apt-repository -y ppa:hvr/ghc+ - sudo apt-get update+ - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH++install:+ - cabal-1.18 update+ - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.+script:+ - cabal-1.18 configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging+ - cabal-1.18 build   # this builds all libraries and executables (including tests/benchmarks)+ - cabal-1.18 test+ - cabal-1.18 check+ - cabal-1.18 sdist   # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal-1.18 install "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi

@@ -0,0 +1,5 @@+import "hint" HLint.Default+import "hint" HLint.Generalise++ignore "Use import/export shortcut"+

@@ -0,0 +1,25 @@+Copyright (c) 2012, Webcrank, Mark Hibberd and others.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. The name of the author may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,100 @@+[Travis](https://travis-ci.org/webcrank/webcrank-dispatch.hs) [![Build Status](https://travis-ci.org/webcrank/webcrank-dispatch.hs.png)](https://travis-ci.org/webcrank/webcrank-dispatch.hs)++A type-safe request dispatcher and path renderer.++```+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++import Webcrank.Dispatch+```++# Paths+## Building Paths++The simplest `Path` is `root`, which is equivalent to `/`.++Other routes can be built with `</>`:++```+docsPath = "package" \<\/> "webcrank-dispatch-0.1" \<\/> "docs"+```++Paths can contain parameters. To create a parameterized path, use+`param` as a path component:++```+docsPath :: Path '[String]+docsPath = "package" </> param </> "docs"+```++Paths can contain as many parameters of varying types as needed:++```+wat :: Path '[String, Int, Bool, Int, String]+wat :: "this" </> param </> param </> "crazyness" </> param </> "ends" </> param </> param+```++Path parameters can be of any type that have instances for `Typeable` and `PathPiece`.++## Rendering Paths++`Path`s can be rendered using `renderPath` and+`params`.++```+>>> renderPath root params+["/"]+```++```+>>> renderPath docsPath $ params "webcrank-dispatch-0.1"+["package", "webcrank-dispatch-0.1", "docs"]+```++```+>>> renderPath wat $ params "down is up" 42 False 7 "up is down"+["this", "down is up", "42", "crazyness", "False", "ends", "7", "up is down"]+```++Note in the last example that no encoding is done by @renderPath@.++# Dispatching++An elementary `Dispatcher` can be built using `==>`.++```+disp = root ==> \"Dispatched\"+```++`Dispatcher`s form a `Monoid`, so more interesting dispatchers can+be built with `<>` or `mconcat`.++```+disp = mconcat+  [ root ==> "Welcome!"+  , "echo" </> param ==> id+  ]+```++Dispatching requests is done with `dispatch`. It turns a+`Dispatcher` into a function from a list of decoded path components+to a possible handler.++```+>>> dispatch (root ==> "Welcome!") [""]+Just "Welcome!"+```++```+>>> dispatch (root ==> "Welcome!") ["echo", "Goodbye!"]+Nothing+```++```+>>> dispatch (root ==> "Welcome!" <> "echo" </> param ==> id) ["echo", "Goodbye!"]+Just "Goodbye!"+```++For more examples see `examples/Main.hs`.

@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain

@@ -0,0 +1,30 @@+Copyright (c) 2014, Richard Wallace++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Richard Wallace nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Data.Monoid+import Data.Text (Text)++import Webcrank.Dispatch++type Res = Text++packages :: Path '[]+packages = "packages"++package :: Path '[Text]+package = packages </> param++packageVer :: Path '[Text, Int]+packageVer = package </> param++packageVerDoc :: Path '[Text, Int]+packageVerDoc = packageVer </> "doc"++packagesResource :: Text+packagesResource = "Packages: webcrank-dispatch webcrank webcrank-wai"++packageResource :: Text -> Text+packageResource "webcrank-dispatch" = "webcrank-dispatch versions: 1 2 3"+packageResource _ = "Not found"++packageVerResource :: Text -> Int -> Text+packageVerResource "webcrank-dispatch" 1 = "webcrank-dispatch v1"+packageVerResource "webcrank-dispatch" 2 = "webcrank-dispatch v2"+packageVerResource "webcrank-dispatch" 3 = "webcrank-dispatch v3"+packageVerResource _ _ = "Not found"++dispatcher :: [Text] -> Maybe Text+dispatcher = dispatch $ mconcat+  [ packages      ==> packagesResource+  , package       ==> packageResource+  , packageVer    ==> packageVerResource+  , packageVerDoc ==> (\_ _ -> "some docs")+  ]++main :: IO ()+main = do+  -- route rendering+  print $ renderPath packages params -- ["packages"]+  print $ renderPath package $ params "webcrank-dispatch" -- ["packages", "webcrank-dispatch"]+  print $ renderPath packageVer $ params "webcrank-dispatch" 1 -- ["packages", "webcrank-dispatch", "1"]+  print $ renderPath packageVerDoc $ params "webcrank-dispatch" 1 -- ["packages", "webcrank-dispatch", "1", "doc"]++  -- dispatching+  print $ dispatcher ["packages"] -- Just "..."+  print $ dispatcher ["unknown"] -- Nothing++  print $ dispatcher ["packages", "webcrank-dispatch"] -- Just "..."+  print $ dispatcher ["packages", "nothing"] -- Just "Not found"++  print $ dispatcher ["packages", "webcrank-dispatch", "2"] -- Just "..."+  print $ dispatcher ["packages", "webcrank-dispatch", "5"] -- Just "Not found"+  print $ dispatcher ["packages", "webcrank-dispatch", "not-an-int"] -- Nothing++  print $ dispatcher ["packages", "webcrank-dispatch", "2", "doc"] -- Just "..."+  print $ dispatcher ["packages", "webcrank-dispatch", "2", "unknown"] -- Nothing+

@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain

@@ -0,0 +1,18 @@+name:                webcrank-dispatch-examples+version:             0.1.0.0+license:             BSD3+license-file:        LICENSE+author:              Richard Wallace+maintainer:          rwallace@thewallacepack.net+category:            Web+build-type:          Simple+cabal-version:       >=1.10++executable examples+  build-depends:       base >=4.7+                     , mtl+                     , reroute+                     , text+                     , webcrank-dispatch+  default-language:    Haskell98+  main-is:             Main.hs

@@ -0,0 +1,172 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Webcrank.Dispatch+-- Copyright   :  (C) 2015 Richard Wallace+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Richard Wallace <rwallace@thewallacepack.net>+-- Stability   :  provisional+-----------------------------------------------------------------------------++module Webcrank.Dispatch+  ( -- * Paths+    -- ** Building Paths+    root+  , (</>)+  , param+  , RR.Path+    -- ** Rendering Paths+  , renderPath+  , params+  , HBuild'(..)+    -- * Dispatching+  , (==>)+  , dispatch+  , Dispatcher+  ) where++import Control.Monad.Identity+import qualified Data.HashMap.Strict as HM+import Data.HVect+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import Data.Typeable (Typeable)+import Web.PathPieces+import Web.Routing.AbstractRouter+import qualified Web.Routing.SafeRouting as RR++-- | The simplest @'Path'@ is the @root@ path, which is equivalent to @/@.+root :: RR.Path '[]+root = RR.root++-- | Other routes can be built with @</>@:+--+-- @+-- docsPath = "package" \<\/> "webcrank-dispatch-0.1" \<\/> "docs"+-- @+(</>) :: RR.Path as -> RR.Path bs -> RR.Path (Append as bs)+(</>) = (RR.</>)++-- | Paths can contain parameters.  To create a parameterized path, use+-- @param@ as a path component:+--+-- @+-- docsPath :: Path '[String]+-- docsPath = "package" \<\/> param \<\/> "docs"+-- @+--+-- Paths can contain as many parameters of varying types as needed:+--+-- @+-- wat :: Path '[String, Int, Bool, Int, String]+-- wat :: "this" \<\/> param \<\/> param \<\/> "crazyness" \<\/> param \<\/> "ends" \<\/> param \<\/> param+-- @+--+-- Path parameters can be of any type that have instances for @'Typeable'@+-- and @'PathPiece'@.+param :: (Typeable a, PathPiece a) => RR.Path (a ': '[])+param = RR.var++-- | @Path@s can be rendered using @'renderPath'@ and+-- @'params'@.+--+-- >>> renderPath root params+-- ["/"]+--+-- >>> renderPath docsPath $ params "webcrank-dispatch-0.1"+-- ["package", "webcrank-dispatch-0.1", "docs"]+--+-- >>> renderPath wat $ params "down is up" 42 False 7 "up is down"+-- ["this", "down is up", "42", "crazyness", "False", "ends", "7", "up is down"]+--+-- Note in the last example that no encoding is done by @renderPath@.+renderPath :: RR.Path l -> HVect l -> [Text]+renderPath = RR.renderRoute'++params :: (HBuild' '[] r) => r+params = hBuild' HNil++class HBuild' l r where+  hBuild' :: HVect l -> r++instance (l' ~ ReverseLoop l '[]) => HBuild' l (HVect l') where+  hBuild' l = hVectReverse l++instance HBuild' (a ': l) r => HBuild' l (a -> r) where+  hBuild' l x = hBuild' (HCons x l)++-- | An elementary @'Dispatcher'@ can be built using @'==>'@.+--+-- @disp = root ==> \"Dispatched\"@+--+-- @Dispatcher@s form a @'Monoid'@, so more interesting dispatchers can+-- be built with @'<>'@ or @'mconcat'@.+--+-- @+-- disp = mconcat+--   [ root ==> "Welcome!"+--   , "echo" </> param ==> id+--   ]+-- @+(==>) :: RR.Path as -> HVectElim as a -> Dispatcher a+(==>) p r = Dispatcher $ hookRoute () (SafeRouterPath p) (RR.HVectElim' r)+infixr 8 ==>++-- | Dispatching requests is done with @'dispatch'@. It turns a+-- @Dispatcher@ into a function from a list of decoded path components+-- to a possible handler.+--+-- >>> dispatch (root ==> "Welcome!") [""]+-- Just "Welcome!"+--+-- >>> dispatch (root ==> "Welcome!") ["echo", "Goodbye!"]+-- Nothing+--+-- >>> dispatch (root ==> "Welcome!" <> "echo" </> param ==> id) ["echo", "Goodbye!"]+-- Just "Goodbye!"+dispatch :: Dispatcher a -> [Text] -> Maybe a+dispatch (Dispatcher r) = case runIdentity $ runRegistry SafeRouter r of+  (_, f, _) -> fmap snd . listToMaybe . f ()++newtype Dispatcher a = Dispatcher (RegistryT (SafeRouter a) () () Identity ())++instance Monoid (Dispatcher a) where+  mempty = Dispatcher $ return ()+  mappend (Dispatcher x) (Dispatcher y) = Dispatcher $ x >> y++data SafeRouter a = SafeRouter++instance AbstractRouter (SafeRouter a) where+  newtype Registry (SafeRouter a) = SafeRouterReg (RR.PathMap a, [[Text] -> a])+  newtype RoutePath (SafeRouter a) xs = SafeRouterPath (RR.Path xs)+  type RouteAction (SafeRouter a) = RR.HVectElim' a+  type RouteAppliedAction (SafeRouter a) = a+  subcompCombine (SafeRouterPath p1) (SafeRouterPath p2) =+    SafeRouterPath $ p1 </> p2+  emptyRegistry = SafeRouterReg (RR.emptyPathMap, [])+  rootPath = SafeRouterPath RR.Empty+  defRoute (SafeRouterPath path) action (SafeRouterReg (a, cAll)) =+    SafeRouterReg+      ( RR.insertPathMap' path (hVectUncurry $ RR.flipHVectElim action) a+      , cAll+      )+  fallbackRoute routeDef (SafeRouterReg (a, cAll)) =+    SafeRouterReg (a, cAll <> [routeDef])+  matchRoute (SafeRouterReg (a, cAll)) pathPieces =+    let matches = RR.match a pathPieces+        matches' =+            if null matches+            then matches <> fmap (\f -> f pathPieces) cAll+            else matches+    in zip (replicate (length matches') HM.empty) matches'+

@@ -0,0 +1,45 @@+name: webcrank-dispatch+version: 0.1+license:            BSD3+license-file:       LICENSE+author:             Richard Wallace <rwallace@thewallacepack.net>+maintainer:         Richard Wallace <rwallace@thewallacepack.net>+copyright:          (c) 2015 Richard Wallace+synopsis:           A simple request dispatcher.+category:           Web+homepage:           https://github.com/webcrank/webcrank-dispatch.hs+bug-reports:        https://github.com/webcrank/webcrank-dispatch.hs/issues+build-type: Simple+cabal-version: >= 1.8+description:        A simple request dispatcher.++extra-source-files:+  .ghci+  .gitignore+  .travis.yml+  examples/LICENSE+  examples/webcrank-dispatch-examples.cabal+  examples/*.hs+  HLint.hs+  LICENSE+  README.md++source-repository   head+  type:             git+  location:         https://github.com/webcrank/webcrank-dispatch.hs.git++library+  hs-source-dirs:      src++  exposed-modules:     Webcrank.Dispatch++  build-depends:       base                >= 4.6 && < 5+                     , bytestring          >= 0.10+                     , mtl                 >= 2.0+                     , path-pieces         >= 0.1+                     , reroute             >= 0.1+                     , text                >= 0.11+                     , unordered-containers >= 0.2++  ghc-options:         -Wall+