diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -8,3 +8,4 @@ Jonas Kramer Jurriën Stutterheim Jasper Van der Jeugt +Bryan O'Sullivan diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.6.0.1 +version: 0.7 synopsis: Snap: A Haskell Web Framework (Core) description: @@ -45,7 +45,7 @@ build-type: Simple cabal-version: >= 1.6 homepage: http://snapframework.com/ -category: Web +category: Web, Snap extra-source-files: test/suite/TestSuite.hs, @@ -91,7 +91,7 @@ logging, and this introduces a tiny amount of overhead (a call into a function pointer) because the calls to 'debug' cannot be inlined. - + Default: False @@ -128,6 +128,7 @@ other-modules: Snap.Internal.Instances, Snap.Internal.Iteratee.BoyerMooreHorspool, + Snap.Internal.Parsing.FastSet, Snap.Internal.Routing, Snap.Internal.Types, Snap.Internal.Test.RequestBuilder, @@ -135,15 +136,15 @@ build-depends: - attoparsec >= 0.8.0.2 && < 0.10, - attoparsec-enumerator >= 0.2.0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && < 5, base16-bytestring <= 0.2, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.3 && < 0.4, + case-insensitive >= 0.3 && < 0.5, containers, deepseq >= 1.1 && <1.3, directory, @@ -156,9 +157,9 @@ mwc-random >= 0.10 && <0.11, old-locale, old-time, - regex-posix <= 0.94.4, + regex-posix <= 0.95.2, text >= 0.11 && <0.12, - time >= 1.0 && < 1.4, + time >= 1.0 && < 1.5, transformers == 0.2.*, unix-compat >= 0.2 && <0.4, unordered-containers >= 0.1.4.3 && <0.2, diff --git a/src/Snap/Core.hs b/src/Snap/Core.hs --- a/src/Snap/Core.hs +++ b/src/Snap/Core.hs @@ -33,7 +33,9 @@ -- ** Access to state , getRequest + , getsRequest , getResponse + , getsResponse , putRequest , putResponse , modifyRequest diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs --- a/src/Snap/Internal/Parsing.hs +++ b/src/Snap/Internal/Parsing.hs @@ -7,10 +7,8 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad -import Data.Attoparsec.Char8 hiding (Done, many) -import qualified Data.Attoparsec.Char8 as Atto -import Data.Attoparsec.FastSet (FastSet) -import qualified Data.Attoparsec.FastSet as FS +import Data.Attoparsec.Types (IResult(..)) +import Data.Attoparsec.Char8 import Data.Bits import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S @@ -34,15 +32,17 @@ ------------------------------------------------------------------------------ import Snap.Internal.Http.Types +import Snap.Internal.Parsing.FastSet (FastSet) +import qualified Snap.Internal.Parsing.FastSet as FS ------------------------------------------------------------------------------ fullyParse :: ByteString -> Parser a -> Either String a fullyParse s p = case r' of - (Fail _ _ e) -> Left e - (Partial _) -> Left "parse failed" - (Atto.Done _ x) -> Right x + (Fail _ _ e) -> Left e + (Partial _) -> Left "parse failed" + (Done _ x) -> Right x where r = parse p s r' = feed r "" @@ -50,7 +50,7 @@ ------------------------------------------------------------------------------ parseNum :: Parser Int64 -parseNum = liftM int $ Atto.takeWhile1 Atto.isDigit +parseNum = liftM int $ takeWhile1 isDigit ------------------------------------------------------------------------------ @@ -257,8 +257,8 @@ where r = parse p s - toResult (Atto.Done _ c) = Just c - toResult _ = Nothing + toResult (Done _ c) = Just c + toResult _ = Nothing ------------------------------------------------------------------------------ @@ -351,9 +351,9 @@ ------------------------------------------------------------------------------ -finish :: Atto.Result a -> Atto.Result a -finish (Atto.Partial f) = flip feed "" $ f "" -finish x = x +finish :: Result a -> Result a +finish (Partial f) = flip feed "" $ f "" +finish x = x diff --git a/src/Snap/Internal/Parsing/FastSet.hs b/src/Snap/Internal/Parsing/FastSet.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Internal/Parsing/FastSet.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BangPatterns, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Snap.Internal.Parsing.FastSet +-- Copyright : Bryan O'Sullivan 2008 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Fast set membership tests for 'Word8' and 8-bit 'Char' values. The +-- set representation is unboxed for efficiency. For small sets, we +-- test for membership using a binary search. For larger sets, we use +-- a lookup table. +-- +-- Note: this module copied here from the attoparsec source because it was made +-- private in version 0.10. +-- +----------------------------------------------------------------------------- +module Snap.Internal.Parsing.FastSet + ( + -- * Data type + FastSet + -- * Construction + , fromList + , set + -- * Lookup + , memberChar + , memberWord8 + -- * Debugging + , fromSet + -- * Handy interface + , charClass + ) where + +import Data.Bits ((.&.), (.|.)) +import Foreign.Storable (peekByteOff, pokeByteOff) +import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#) +import GHC.Word (Word8(W8#)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as I +import qualified Data.ByteString.Unsafe as U + +data FastSet = Sorted { fromSet :: !B.ByteString } + | Table { fromSet :: !B.ByteString } + deriving (Eq, Ord) + +instance Show FastSet where + show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s) + show (Table _) = "FastSet Table" + +-- | The lower bound on the size of a lookup table. We choose this to +-- balance table density against performance. +tableCutoff :: Int +tableCutoff = 8 + +-- | Create a set. +set :: B.ByteString -> FastSet +set s | B.length s < tableCutoff = Sorted . B.sort $ s + | otherwise = Table . mkTable $ s + +fromList :: [Word8] -> FastSet +fromList = set . B.pack + +data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 + +shiftR :: Int -> Int -> Int +shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) + +shiftL :: Word8 -> Int -> Word8 +shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) + +index :: Int -> I +index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7)) +{-# INLINE index #-} + +-- | Check the set for membership. +memberWord8 :: Word8 -> FastSet -> Bool +memberWord8 w (Table t) = + let I byte bit = index (fromIntegral w) + in U.unsafeIndex t byte .&. bit /= 0 +memberWord8 w (Sorted s) = search 0 (B.length s - 1) + where search lo hi + | hi < lo = False + | otherwise = + let mid = (lo + hi) `div` 2 + in case compare w (U.unsafeIndex s mid) of + GT -> search (mid + 1) hi + LT -> search lo (mid - 1) + _ -> True + +-- | Check the set for membership. Only works with 8-bit characters: +-- characters above code point 255 will give wrong answers. +memberChar :: Char -> FastSet -> Bool +memberChar c = memberWord8 (I.c2w c) +{-# INLINE memberChar #-} + +mkTable :: B.ByteString -> B.ByteString +mkTable s = I.unsafeCreate 32 $ \t -> do + _ <- I.memset t 0 32 + U.unsafeUseAsCStringLen s $ \(p, l) -> + let loop n | n == l = return () + | otherwise = do + c <- peekByteOff p n :: IO Word8 + let I byte bit = index (fromIntegral c) + prev <- peekByteOff t byte :: IO Word8 + pokeByteOff t byte (prev .|. bit) + loop (n + 1) + in loop 0 + +charClass :: String -> FastSet +charClass = set . B8.pack . go + where go (a:'-':b:xs) = [a..b] ++ go xs + go (x:xs) = x : go xs + go _ = "" diff --git a/src/Snap/Internal/Routing.hs b/src/Snap/Internal/Routing.hs --- a/src/Snap/Internal/Routing.hs +++ b/src/Snap/Internal/Routing.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} module Snap.Internal.Routing where @@ -90,15 +91,19 @@ routeHeight r = case r of NoRoute -> 1 (Action _) -> 1 - (Capture _ r' _) -> 1+routeHeight r' - (Dir rm _) -> 1+foldl max 1 (map routeHeight $ Map.elems rm) + (Capture _ r' _) -> 1 + routeHeight r' + (Dir rm _) -> 1 + foldl max 1 (map routeHeight $ Map.elems rm) +{-# INLINE routeHeight #-} + +------------------------------------------------------------------------------ routeEarliestNC :: Route a m -> Int -> Int routeEarliestNC r n = case r of NoRoute -> n (Action _) -> n (Capture _ r' _) -> routeEarliestNC r' n+1 (Dir _ _) -> n +{-# INLINE routeEarliestNC #-} ------------------------------------------------------------------------------ @@ -150,12 +155,29 @@ -- > , ("article/:id", renderArticle) -- > , ("login", method POST doLogin) ] -- +-- +-- /URL decoding/ +-- +-- A short note about URL decoding: path matching and variable capture are done +-- on /decoded/ URLs, but the contents of 'rqContextPath' and 'rqPathInfo' will +-- contain the original encoded URL, i.e. what the user entered. For example, +-- in the following scenario: +-- +-- > route [ ("a b c d/", foo ) ] +-- +-- A request for \"@/a+b+c+d@\" will be sent to @foo@ with 'rqContextPath' set +-- to \"/a+b+c+d/\". +-- +-- This behaviour changed as of Snap 0.6.1; previous versions had unspecified +-- (and buggy!) semantics here. +-- route :: MonadSnap m => [(ByteString, m a)] -> m a route rts = do - p <- getRequest >>= maybe pass return . urlDecode . rqPathInfo - route' (return ()) ([], splitPath p) Map.empty rts' + p <- getsRequest rqPathInfo + route' (return ()) [] (splitPath p) Map.empty rts' where rts' = mconcat (map pRoute rts) +{-# INLINE route #-} ------------------------------------------------------------------------------ @@ -168,18 +190,19 @@ req <- getRequest let ctx = rqContextPath req let p = rqPathInfo req - p' <- maybe pass return $ urlDecode p let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p} - (route' md ([], splitPath p') Map.empty rts') <|> (md >> pass) + (route' md [] (splitPath p) Map.empty rts') <|> (md >> pass) where rts' = mconcat (map pRoute rts) +{-# INLINE routeLocal #-} ------------------------------------------------------------------------------ splitPath :: ByteString -> [ByteString] splitPath = B.splitWith (== (c2w '/')) +{-# INLINE splitPath #-} ------------------------------------------------------------------------------ @@ -190,16 +213,19 @@ f s rt = if B.head s == c2w ':' then Capture (B.tail s) rt NoRoute else Dir (Map.fromList [(s, rt)]) NoRoute +{-# INLINE pRoute #-} ------------------------------------------------------------------------------ route' :: MonadSnap m - => m () - -> ([ByteString], [ByteString]) + => m () -- ^ action to run before we call the user handler + -> [ByteString] -- ^ the \"context\"; the list of path segments we've + -- already successfully matched, in reverse order + -> [ByteString] -- ^ the list of path segments we haven't yet matched -> Params -> Route a m -> m a -route' pre (ctx, _) params (Action action) = +route' pre !ctx _ !params (Action action) = localRequest (updateContextPath (B.length ctx') . updateParams) (pre >> action) where @@ -207,20 +233,26 @@ updateParams req = req { rqParams = Map.unionWith (++) params (rqParams req) } -route' pre (ctx, []) params (Capture _ _ fb) = - route' pre (ctx, []) params fb -route' pre (ctx, cwd:rest) params (Capture p rt fb) = - (route' pre (cwd:ctx, rest) params' rt) <|> - (route' pre (ctx, cwd:rest) params fb) +route' pre !ctx [] !params (Capture _ _ fb) = + route' pre ctx [] params fb + +route' pre !ctx (cwd:rest) !params (Capture p rt fb) = + m <|> (route' pre ctx (cwd:rest) params fb) where - params' = Map.insertWith (++) p [cwd] params + m = do + maybe pass + (\cwd' -> let params' = Map.insertWith (++) p [cwd'] params + in route' pre (cwd:ctx) rest params' rt) + (urlDecode cwd) + -route' pre (ctx, []) params (Dir _ fb) = - route' pre (ctx, []) params fb -route' pre (ctx, cwd:rest) params (Dir rtm fb) = - case Map.lookup cwd rtm of - Just rt -> (route' pre (cwd:ctx, rest) params rt) <|> - (route' pre (ctx, cwd:rest) params fb) - Nothing -> route' pre (ctx, cwd:rest) params fb +route' pre !ctx [] !params (Dir _ fb) = + route' pre ctx [] params fb +route' pre !ctx (cwd:rest) !params (Dir rtm fb) = do + cwd' <- maybe pass return $ urlDecode cwd + case Map.lookup cwd' rtm of + Just rt -> (route' pre (cwd:ctx) rest params rt) <|> + (route' pre ctx (cwd:rest) params fb) + Nothing -> route' pre ctx (cwd:rest) params fb -route' _ _ _ NoRoute = pass +route' _ _ _ _ NoRoute = pass diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -540,10 +540,26 @@ ------------------------------------------------------------------------------ +-- | Grabs something out of the 'Request' object, using the given projection +-- function. See 'gets'. +getsRequest :: MonadSnap m => (Request -> a) -> m a +getsRequest f = liftSnap $ liftM (f . _snapRequest) sget +{-# INLINE getsRequest #-} + + +------------------------------------------------------------------------------ -- | Grabs the 'Response' object out of the 'Snap' monad. getResponse :: MonadSnap m => m Response getResponse = liftSnap $ liftM _snapResponse sget {-# INLINE getResponse #-} + + +------------------------------------------------------------------------------ +-- | Grabs something out of the 'Response' object, using the given projection +-- function. See 'gets'. +getsResponse :: MonadSnap m => (Response -> a) -> m a +getsResponse f = liftSnap $ liftM (f . _snapResponse) sget +{-# INLINE getsResponse #-} ------------------------------------------------------------------------------ diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -687,8 +687,9 @@ unsafeEnumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a unsafeEnumBuilderToByteString = - builderToByteStringWith (reuseBufferStrategy (allocBuffer 65536)) - + builderToByteStringWith (reuseBufferStrategy (allocBuffer bufsize)) + where + bufsize = (2::Int) ^ (14::Int) ------------------------------------------------------------------------------ enumByteStringToBuilder :: MonadIO m => Enumeratee ByteString Builder m a diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -32,7 +32,7 @@ import Control.Monad import Control.Monad.CatchIO import Control.Monad.Trans -import Data.Attoparsec.Char8 hiding (Done) +import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) import Data.ByteString.Internal (c2w) diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs --- a/src/Snap/Util/FileUploads.hs +++ b/src/Snap/Util/FileUploads.hs @@ -72,7 +72,7 @@ import Control.Monad.CatchIO import Control.Monad.Trans import qualified Data.Attoparsec.Char8 as Atto -import Data.Attoparsec.Char8 hiding (many, Result(..)) +import Data.Attoparsec.Char8 import Data.Attoparsec.Enumerator import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -11,11 +11,11 @@ import Blaze.ByteString.Builder import qualified Codec.Zlib.Enum as Z -import Control.Applicative hiding (many) +import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans -import Data.Attoparsec.Char8 hiding (Done) +import Data.Attoparsec.Char8 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.Char as Char diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -23,15 +23,15 @@ build-depends: QuickCheck >= 2.3.0.2, - attoparsec >= 0.8.1 && < 0.10, - attoparsec-enumerator >= 0.2.0.3, + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3, base >= 4 && < 5, base16-bytestring == 0.1.*, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.3 && < 0.4, + case-insensitive >= 0.3 && < 0.5, cereal == 0.3.*, containers, deepseq >= 1.1 && <1.3, diff --git a/test/suite/Snap/Internal/Routing/Tests.hs b/test/suite/Snap/Internal/Routing/Tests.hs --- a/test/suite/Snap/Internal/Routing/Tests.hs +++ b/test/suite/Snap/Internal/Routing/Tests.hs @@ -51,7 +51,10 @@ , testRouting26 , testRouting27 , testRouting28 - , testRouteLocal ] + , testRouteLocal + , testRouteUrlDecode + , testRouteUrlEncodedPath + ] expectException :: IO a -> IO () expectException m = do @@ -77,18 +80,21 @@ dummy = const $ return () routes :: Snap ByteString -routes = route [ ("foo" , topFoo ) - , ("foo/bar" , fooBar ) - , ("foo/bar/baz" , fooBarBaz ) - , ("foo/:id" , fooCapture) - , ("bar/:id" , fooCapture) - , ("bar/quux" , barQuux ) - , ("bar" , bar ) - , ("z/:a/:b/:c/d" , zabc ) ] +routes = route [ ("foo" , topFoo ) + , ("foo/bar" , fooBar ) + , ("foo/bar/baz" , getRqPathInfo ) + , ("foo/:id" , fooCapture ) + , ("bar/:id" , fooCapture ) + , ("herp/:derp/" , getRqPathInfo ) + , ("nerp/:derp/" , getRqContextPath) + , ("a b c d" , return "OK" ) + , ("bar/quux" , barQuux ) + , ("bar" , bar ) + , ("z/:a/:b/:c/d" , zabc ) ] routesLocal :: Snap ByteString -routesLocal = routeLocal [ ("foo/bar/baz" , fooBarBaz ) - , ("bar" , pass ) ] +routesLocal = routeLocal [ ("foo/bar/baz" , getRqPathInfo ) + , ("bar" , pass ) ] routes2 :: Snap ByteString routes2 = route [ ("" , topTop ) @@ -119,8 +125,9 @@ , ("" , topTop ) ] -topTop, topFoo, fooBar, fooCapture, fooBarBaz, bar, barQuux :: Snap ByteString -dblA, zabc, topCapture, fooCapture2 :: Snap ByteString +topTop, topFoo, fooBar, fooCapture, getRqPathInfo, bar, + getRqContextPath, barQuux, dblA, zabc, topCapture, + fooCapture2 :: Snap ByteString dblA = do ma <- getParam "a" @@ -145,158 +152,174 @@ mp <- getParam "foo" maybe pass return mp -topTop = return "topTop" -topFoo = return "topFoo" -fooBar = return "fooBar" -fooCapture = liftM (head . fromJust . rqParam "id") getRequest -fooCapture2 = liftM (head . fromJust . rqParam "id2") getRequest -fooBarBaz = liftM rqPathInfo getRequest -barQuux = return "barQuux" -bar = return "bar" +topTop = return "topTop" +topFoo = return "topFoo" +fooBar = return "fooBar" +fooCapture = liftM (head . fromJust . rqParam "id") getRequest +fooCapture2 = liftM (head . fromJust . rqParam "id2") getRequest +getRqPathInfo = liftM rqPathInfo getRequest +getRqContextPath = liftM rqContextPath getRequest +barQuux = return "barQuux" +bar = return "bar" -- TODO more useful test names testRouting1 :: Test -testRouting1 = testCase "routing1" $ do +testRouting1 = testCase "route/1" $ do r1 <- go routes "foo" assertEqual "/foo" "topFoo" r1 testRouting2 :: Test -testRouting2 = testCase "routing2" $ do +testRouting2 = testCase "route/2" $ do r2 <- go routes "foo/baz" assertEqual "/foo/baz" "baz" r2 testRouting3 :: Test -testRouting3 = testCase "routing3" $ do +testRouting3 = testCase "route/3" $ do expectException $ go routes "/xsaxsaxsax" testRouting4 :: Test -testRouting4 = testCase "routing4" $ do +testRouting4 = testCase "route/4" $ do r3 <- go routes "foo/bar" assertEqual "/foo/bar" "fooBar" r3 testRouting5 :: Test -testRouting5 = testCase "routing5" $ do +testRouting5 = testCase "route/5" $ do r4 <- go routes "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "quux" r4 testRouting6 :: Test -testRouting6 = testCase "routing6" $ do +testRouting6 = testCase "route/6" $ do r5 <- go routes "foo/bar/sproing" assertEqual "/foo/bar/sproing" "fooBar" r5 testRouting7 :: Test -testRouting7 = testCase "routing7" $ do +testRouting7 = testCase "route/7" $ do r <- go routes "bar" assertEqual "/bar" "bar" r testRouting8 :: Test -testRouting8 = testCase "routing8" $ do +testRouting8 = testCase "route/8" $ do r2 <- go routes "bar/quux" assertEqual "/bar/quux" "barQuux" r2 testRouting9 :: Test -testRouting9 = testCase "routing9" $ do +testRouting9 = testCase "route/9" $ do r3 <- go routes "bar/whatever" assertEqual "/bar/whatever" "whatever" r3 testRouting10 :: Test -testRouting10 = testCase "routing10" $ do +testRouting10 = testCase "route/10" $ do r4 <- go routes "bar/quux/whatever" assertEqual "/bar/quux/whatever" "barQuux" r4 testRouting11 :: Test -testRouting11 = testCase "routing11" $ do +testRouting11 = testCase "route/11" $ do r1 <- go routes2 "" assertEqual "/" "topTop" r1 testRouting12 :: Test -testRouting12 = testCase "routing12" $ do +testRouting12 = testCase "route/12" $ do r1 <- go routes2 "foo" assertEqual "/foo" "topFoo" r1 testRouting13 :: Test -testRouting13 = testCase "routing13" $ do +testRouting13 = testCase "route/13" $ do r1 <- go routes3 "zzzz" assertEqual "/zzzz" "zzzz" r1 testRouting14 :: Test -testRouting14 = testCase "routing14" $ do +testRouting14 = testCase "route/14" $ do r1 <- go routes3 "" assertEqual "/" "topTop" r1 testRouting15 :: Test -testRouting15 = testCase "routing15" $ do +testRouting15 = testCase "route/15" $ do r1 <- go routes4 "zzzz" assertEqual "/zzzz" "zzzz" r1 testRouting16 :: Test -testRouting16 = testCase "routing16" $ do +testRouting16 = testCase "route/16" $ do r1 <- go routes5 "" assertEqual "/" "topTop" r1 testRouting17 :: Test -testRouting17 = testCase "routing17" $ do +testRouting17 = testCase "route/17" $ do r1 <- go routes "z/a/b/c/d" assertEqual "/z/a/b/c/d" "ok" r1 testRouting18 :: Test -testRouting18 = testCase "routing18" $ do +testRouting18 = testCase "route/18" $ do r1 <- go routes6 "a/a" assertEqual "/a/a" "ok" r1 testRouting19 :: Test -testRouting19 = testCase "routing19" $ do +testRouting19 = testCase "route/19" $ do r1 <- go routes7 "foo" assertEqual "/foo" "topTop" r1 testRouting20 :: Test -testRouting20 = testCase "routing20" $ do +testRouting20 = testCase "route/20" $ do r1 <- go routes7 "foo/baz" assertEqual "/foo/baz" "baz" r1 testRouting21 :: Test -testRouting21 = testCase "routing21" $ do +testRouting21 = testCase "route/21" $ do r1 <- go routes7 "foo/baz/quux" assertEqual "/foo/baz/quux" "quux" r1 testRouting22 :: Test -testRouting22 = testCase "routing22" $ do +testRouting22 = testCase "route/22" $ do r1 <- go routes7 "fooo/baz" assertEqual "/fooo/baz" "topTop" r1 testRouting23 :: Test -testRouting23 = testCase "routing23" $ do +testRouting23 = testCase "route/23" $ do r1 <- go routes7 "fooo/baz/quux" assertEqual "/fooo/baz/quux" "quux" r1 testRouting24 :: Test -testRouting24 = testCase "routing24" $ do +testRouting24 = testCase "route/24" $ do r1 <- go routes7 "foooo/bar/bax" assertEqual "/foooo/bar/bax" "topTop" r1 testRouting25 :: Test -testRouting25 = testCase "routing25" $ do +testRouting25 = testCase "route/25" $ do r1 <- go routes7 "foooo/bar/baz" assertEqual "/foooo/bar/baz" "bar" r1 testRouting26 :: Test -testRouting26 = testCase "routing26" $ do +testRouting26 = testCase "route/26" $ do r1 <- go routes4 "foo/bar" assertEqual "capture union" "bar" r1 testRouting27 :: Test -testRouting27 = testCase "routing27" $ do +testRouting27 = testCase "route/27" $ do r1 <- go routes4 "foo" assertEqual "capture union" "foo" r1 testRouting28 :: Test -testRouting28 = testCase "routing28" $ do +testRouting28 = testCase "route/28" $ do r1 <- go routes4 "quux/baz" assertEqual "capture union" "quux" r1 +testRouteUrlDecode :: Test +testRouteUrlDecode = testCase "route/urlDecode" $ do + r1 <- go routes "herp/%7Bderp%7D/" + assertEqual "rqPathInfo on urldecode" "" r1 + r2 <- go routes "foo/%7Bderp%7D/" + assertEqual "urldecoded capture" "{derp}" r2 + r3 <- go routes "nerp/%7Bderp%7D/" + assertEqual "rqContextPath on urldecode" "/nerp/%7Bderp%7D/" r3 + +testRouteUrlEncodedPath :: Test +testRouteUrlEncodedPath = testCase "route/urlEncodedPath" $ do + -- make sure path search urlDecodes. + r1 <- go routes "a+b+c+d" + assertEqual "urlEncoded search works" "OK" r1 + testRouteLocal :: Test -testRouteLocal = testCase "routeLocal" $ do +testRouteLocal = testCase "route/routeLocal" $ do r4 <- go routesLocal "foo/bar/baz/quux" assertEqual "/foo/bar/baz/quux" "foo/bar/baz/quux" r4 expectException $ go routesLocal "bar"