packages feed

web-routing (empty) → 0.1.0

raw patch · 9 files changed

+531/−0 lines, 9 filesdep +basedep +bytestringdep +doctestsetup-changed

Dependencies added: base, bytestring, doctest, tasty, tasty-quickcheck, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 HirotomoMoriwaki++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:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/Routing.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE FlexibleContexts #-} -- for ghc-7.6+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++-- | >>> :set -XDataKinds -XOverloadedStrings -XNoMonomorphismRestriction+-- >>> import Data.Proxy (Proxy(..))+-- >>> import Text.Read(readMaybe)+-- >>> import qualified Data.Text as T+--+-- 1. create path+--+-- >>> data Result = A | B T.Text | C | D Int deriving Show+-- >>> let a = root $ exact "foo" $ action Nothing (\_ -> Just A)+-- >>> let b = root $ exact "bar" $ fetch (Proxy :: Proxy "key") Just $ action Nothing (\d -> Just . B $ D.get (Proxy :: Proxy "key") d)+-- >>> let c = root $ exact "bar" $ any $ action (Just "GET") (\_ -> Just C)+-- >>> let d = root $ exact "bar" $ fetch (Proxy :: Proxy "key") (\t -> readMaybe (T.unpack t) :: Maybe Int) $ action Nothing (\d -> Just . D $ D.get (Proxy :: Proxy "key") d)+-- >>> a+-- * /foo+-- >>> b+-- * /bar/:key+-- >>> c+-- GET /bar/**+-- >>> d+-- * /bar/:key+--+-- 2. create router+--+-- >>> let r = d +| a +| b +| c +| empty+--+-- 3. execute router+--+-- >>> let run = execute r+--+-- >>> run "GET" ["foo"]+-- Just A+-- >>> run "GET" ["foo", "bar"]+-- Nothing+-- >>> run "GET" ["bar", "12"]+-- Just (D 12)+-- >>> run "GET" ["bar", "baz"]+-- Just (B "baz")+-- >>> run "GET" ["bar", "baz", "qux"]+-- Just C+-- >>> run "POST" ["bar", "baz", "qux"]+-- Nothing++module Network.Routing+    ( Method+      -- * Path +    , Path+      -- ** Path constructors+    , root+      -- *** children+    , exact+      -- *** action+    , action+      -- *** get parameter+    , Raw+    , raw+    , fetch+    , any+    , rest++    -- * Router+    , Router+    , empty+    , add, (+|)++    -- * execute+    , execute+    ) where++import Prelude hiding(any)+import Control.Monad(MonadPlus(..))++import Network.Routing.Compat(KnownSymbol, symbolVal)+import qualified Network.Routing.Dict as D+import qualified Data.Text as T+import qualified Data.HashMap.Strict as H+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as SC++type Method = S.ByteString++data Params d m a where+    PCons :: (D.Dict d -> [T.Text] -> m (D.Dict d', [T.Text]))+          -> Router d' m a+          -> Params d m a -> Params d m a+    PNil  :: Params d m a++-- | routing path+data Path d m a where+    Exact :: T.Text -> Path d m a -> Path d m a++    Param :: String -> (D.Dict d -> [T.Text] -> m (D.Dict d', [T.Text]))+          -> Path d' m a -> Path d m a++    Action :: Maybe Method+           -> (D.Dict d -> m a) -> Path d m a++-- | root+--+-- @+-- root == id+-- @+root :: Path '[] m a -> Path '[] m a+root = id++-- | exact matching path+exact :: T.Text -> Path d m a -> Path d m a+exact = Exact++type Raw m d d'+    = D.Dict d -- ^ input dictionary+    -> [T.Text] -- ^ input path information+    -> m (D.Dict d', [T.Text]) -- ^ output dictionary and path information++-- | raw get parameter function+--+-- if you want matching exact path, use 'exact' for performance+raw :: String -- ^ pretty print+    -> Raw m d d'+    -> Path d' m a -> Path d m a+raw = Param++-- ^ get one directory as parameter.+fetch :: (MonadPlus m, KnownSymbol k, k D.</ d)+      => proxy k -- ^ dictionary key+      -> (T.Text -> Maybe v) -- ^ reading function+      -> Path (k D.:= v ': d) m a -> Path d m a+fetch p f = Param (':' : symbolVal p) go+  where+    go _ [] = mzero+    go d (t:ts) = case f t of+        Nothing -> mzero+        Just v  -> return (D.add p v d, ts)++-- | drop any pathes+any :: Monad m => Path d m a -> Path d m a+any = Param "**" go+  where+    go d _ = return (d, [])++-- | take any pathes as [Text]+rest :: (KnownSymbol k, Monad m, k D.</ d) => proxy k -- ^ dictionary key+     -> Path (k D.:= [T.Text] ': d) m a -> Path d m a+rest k = Param (':': symbolVal k ++ "**") go+  where+    go d r = return (D.add k r d, [])++-- | action+action :: Maybe Method -- ^ if Nothing, any method allowed+       -> (D.Dict d -> m a) -- ^ action when route matching+       -> Path d m a+action  = Action++instance Show (Path d m a) where+    show = go id+      where+        go :: (String -> String) -> Path d m a -> String+        go s (Exact t ps) = go (s . (++) ('/' : T.unpack t)) ps+        go s (Param l _ ps) = go (s . (++) ('/': l)) ps+        go s (Action m _) = maybe "*" SC.unpack m ++ ' ': s []++-- | router+data Router d m a where+    Router ::+        { params    :: Params d m a+        , children  :: H.HashMap T.Text (Router d m a)+        , methods   :: H.HashMap Method (D.Dict d -> m a)+        , anyMethod :: D.Dict d -> m a+        } -> Router d m a++emptyRouter :: MonadPlus m => Router d m a+emptyRouter = Router { params    = PNil+                     , children  = H.empty+                     , methods   = H.empty+                     , anyMethod = const mzero+                     }++-- | empty router+empty :: MonadPlus m => Router '[] m a+empty = emptyRouter++add' :: MonadPlus m => Path d m a -> Router d m a -> Router d m a+add' (Exact p n) r =+    let c = H.lookupDefault emptyRouter p (children r)+    in r { children = H.insert p (add' n c) (children r) }++add' (Param _ f n) Router{..} = Router+    { params    = PCons f (add' n emptyRouter) params+    , children  = children+    , methods   = methods+    , anyMethod = anyMethod+    }++add' (Action (Just m) n) r = +    let c = case H.lookup m (methods r) of+            Nothing -> \d -> n d+            Just p  -> \d -> p d `mplus` n d+    in r { methods = H.insert m c (methods r) }++add' (Action Nothing n) r =+    r { anyMethod = \d -> anyMethod r d `mplus` n d }++-- | insert path to router+add :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a+add = add'++-- | infix version of 'add'+(+|) :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a+(+|) = add++infixr `add`+infixr +|++-- | execute router+execute :: MonadPlus m => Router '[] m a -> Method -> [T.Text] -> m a+execute = execute' D.empty++execute' :: MonadPlus m => D.Dict d -> Router d m a -> Method -> [T.Text] -> m a+execute' d Router{params, methods, anyMethod} m [] = fetching d m [] params `mplus`+    case H.lookup m methods of+        Nothing -> anyMethod d+        Just f  -> f d++execute' d Router{params, children} m pps@(p:ps) = child `mplus` fetching d m pps params+  where+    child = case H.lookup p children of+        Nothing -> mzero+        Just c  -> execute' d c m ps++fetching :: MonadPlus m => D.Dict d -> Method -> [T.Text] -> Params d m a -> m a+fetching d m pps = loop+  where+    loop PNil = mzero+    loop (PCons f r o) =+        do (d', pps') <- f d pps+           execute' d' r m pps'+        `mplus` loop o
+ src/Network/Routing/Compat.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE CPP #-}++-- | compatibility module for ghc-7.8 & ghc-7.6.+module Network.Routing.Compat+    ( Symbol, KnownSymbol, symbolVal+    , Proxy(..)+    ) where++import GHC.TypeLits++#if __GLASGOW_HASKELL__ > 707+import Data.Proxy+#else+type KnownSymbol (n :: Symbol) = SingRep n String++symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String+symbolVal _ = fromSing (sing :: Sing n)+{-# INLINE symbolVal #-}++data Proxy (t :: k) = Proxy+#endif
+ src/Network/Routing/Dict.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-} -- for ghc-7.6+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}++module Network.Routing.Dict+    ( -- * dictionary+      Dict+    , ShowDict+    , KV(..)+    , empty++      -- * insert+    , type (</)+    , add++      -- * get+    , Member+    , get++      -- * convenient+    , Members+    ) where++import GHC.Exts(Constraint)++import Network.Routing.Tree++#if __GLASGOW_HASKELL__ > 707+import GHC.TypeLits+#endif++import Network.Routing.Compat+import Data.Typeable(typeOf, Typeable, TypeRep)+import Data.List(intercalate)+import Unsafe.Coerce++-- | (kind) key-value pair+data KV v = Symbol := v++-- | heterogeneous dictionary+newtype Dict (kvs :: [KV *]) = Dict Tree++class ShowDict (kvs :: [KV *]) where+    showDict :: Int -> Dict kvs -> [(String, String, TypeRep)]++instance ShowDict '[] where+    showDict _ _ = []++instance (KnownSymbol k, Typeable v, Show v, ShowDict kvs) => ShowDict (k := v ': kvs) where+    showDict i (Dict t) =+        (symbolVal (Proxy :: Proxy k), show (unsafeCoerce $ index t i :: v), typeOf (undefined :: v)):+        showDict (i + 1) (unsafeCoerce $ Dict t :: Dict kvs)++instance ShowDict kvs => Show (Dict kvs) where+    show d = "Dict {" +++        (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d)+        ++ "}"++-- | empty dictionary+empty :: Dict '[]+empty = Dict Tip++-- | result type for pretty printing type error.+data HasKeyResult+    = AlreadyExists Symbol+    | Dictionary++#if __GLASGOW_HASKELL__ > 707+type family HasKey (k :: Symbol) (kvs :: [KV *]) :: HasKeyResult where+  HasKey k '[] = AlreadyExists k+  HasKey k (k  := v ': kvs) = Dictionary+  HasKey k (k' := v ': kvs) = HasKey k kvs+#else+type family   HasKey (k :: Symbol) (kvs :: [KV *]) :: HasKeyResult+type instance HasKey k kvs = AlreadyExists k+#endif++-- | 'not elem key' constraint(ghc >= 7.8)+type k </ v = HasKey k v ~ AlreadyExists k++-- | add key value pair to dictionary.+--+-- >>> let a = add (Proxy :: Proxy "foo") (12 :: Int) empty+-- >>> a+-- Dict {foo = 12 :: Int}+--+-- >>> add (Proxy :: Proxy "bar") "baz" a+-- Dict {bar = "baz" :: [Char], foo = 12 :: Int}+add :: (k </ kvs) => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)+add _ v (Dict d) = Dict (unsafeCoerce v `cons` d)++#if __GLASGOW_HASKELL__ > 707+type family Ix (k :: Symbol) (kvs :: [KV *]) :: Nat where+  Ix k (k  := v ': kvs) = 0+  Ix k (k' := v ': kvs) = 1 + Ix k kvs++getImpl :: forall proxy k kvs v. KnownNat (Ix k kvs) => proxy (k :: Symbol) -> Dict kvs -> v+getImpl _ (Dict d) = unsafeCoerce $ d `index` fromIntegral (natVal (Proxy :: Proxy (Ix k kvs)))++class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where+    get' :: proxy k -> Dict kvs -> v++instance Member k v (k := v ': kvs) where+    get' = getImpl+    {-# INLINE get' #-}++instance (Member k v kvs, KnownNat (Ix k (k' := v' ': kvs))) => Member k v (k' := v' ': kvs) where+    get' = getImpl+    {-# INLINE get' #-}++get = get'+#else+class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where+    get' :: Int -> proxy k -> Dict kvs -> v++instance Member k v (k := v ': kvs) where+    get' !i _ (Dict d) = unsafeCoerce $ d `index` i++instance Member k v kvs => Member k v (k' := v' ': kvs) where+    get' !i k d = get' (i + 1) k (unsafeCoerce d :: Dict kvs)++get = get' 0+#endif++-- | get key from dictionary+--+-- >>> let d = add (Proxy :: Proxy "foo") 12 $ add (Proxy :: Proxy "bar") "baz" empty+-- >>> get (Proxy :: Proxy "foo") d+-- 12+-- >>> get (Proxy :: Proxy "bar") d+-- "baz"+get :: Member k v kvs => proxy k -> Dict kvs -> v++-- | type family to constraint multi kvs.+--+-- > Members ["foo" := Int, "bar" := Double] prms == (Member "foo" Int prms, Member "bar" Double prms)+--+type family   Members (kvs :: [KV *]) (prms :: [KV *]) :: Constraint+type instance Members '[] prms = ()+type instance Members (k := v ': kvs) prms = (Member k v prms, Members kvs prms)
+ src/Network/Routing/Tree.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE BangPatterns #-}++module Network.Routing.Tree+    ( Tree(Tip)+    , cons+    , index+    , ) where++import GHC.Exts(Any)++data Dir = L | R++data Tree+    = Branch !Dir !Any !Tree !Tree+    | Tip++cons :: Any -> Tree -> Tree+cons v Tip = Branch L v Tip Tip+cons v (Branch _ a Tip Tip) = Branch R v (Branch L a Tip Tip) Tip+cons v (Branch _ a l   Tip) = Branch L v l (Branch L a Tip Tip)+cons v (Branch L a l   r)   = Branch R v (cons a l) r+cons v (Branch R a l   r)   = Branch L v l (cons a r)++index :: Tree -> Int -> Any+index Tip _ = error "out of range"+index (Branch _ v _ _) 0 = v+index (Branch L _ l r) !i | even i    = index l (i `quot` 2 - 1)+                          | otherwise = index r (i `quot` 2)+index (Branch R _ l r) !i | odd i     = index l (i `quot` 2)+                          | otherwise = index r (i `quot` 2 - 1)
+ tests/doctest.hs view
@@ -0,0 +1,2 @@+import Test.DocTest+main = doctest ["-isrc", "src/Network/Routing.hs"]
+ tests/tasty.hs view
@@ -0,0 +1,7 @@+import Test.Tasty+import qualified Tree++main :: IO ()+main = defaultMain $ testGroup ""+    [ Tree.test+    ]
+ web-routing.cabal view
@@ -0,0 +1,46 @@+name:                web-routing+version:             0.1.0+synopsis:            simple routing library+-- description:         +license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage:            https://github.com/philopon/web-routing+Bug-reports:         https://github.com/philopon/web-routing/issues+copyright:           (c) 2015 Hirotomo Moriwaki+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Network.Routing+                       Network.Routing.Dict+  other-modules:       Network.Routing.Tree+                       Network.Routing.Compat+  build-depends:       base                 >=4.6  && <4.8+                     , bytestring           >=0.10 && <0.11+                     , text                 >=1.2  && <1.3 +                     , unordered-containers >=0.2  && <0.3+  ghc-options:         -O2 -Wall+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite doctests+  type:                exitcode-stdio-1.0+  ghc-options:         -threaded+  main-is:             doctest.hs+  hs-source-dirs:      tests+  build-depends:       base    >=4.6 && <4.8+                     , doctest >=0.9 && <0.10+  default-language:    Haskell2010++test-suite tasty+  type:                exitcode-stdio-1.0+  ghc-options:         -threaded+  main-is:             tasty.hs+  hs-source-dirs:      tests, src+  build-depends:       base             >=4.6  && <4.8+                     , tasty            >=0.10 && <0.11+                     , tasty-quickcheck >=0.8  && <0.9+  default-language:    Haskell2010