git.iko.soy/typeable/wai
on master help sign in
Add UrlMap (with tests)
commita7de40c5904be15178cc7de279aaf88e3d5eba9a authorHarry Garrood <hdgarrood@gmail.com> dateSat 4 Jan 2014, 00:11 (13 years ago) parente7a3a6a
3 files changed+151
compare with master
unifiedsplit
wai-extra/Network/Wai/UrlMap.hs+85 wai-extra/test/WaiExtraTest.hs+65 wai-extra/wai-extra.cabal+1
wai-extra/Network/Wai/UrlMap.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
2+module Network.Wai.UrlMap (
3+ UrlMap,
4+ mount,
5+ mount',
6+ mountRoot,
7+ mapUrls
8+) where
9+
10+import Control.Applicative
11+import Data.List
12+import Data.Text (Text)
13+import qualified Data.Text as T
14+import qualified Data.Text.Encoding as T
15+import qualified Data.ByteString as B
16+import Network.HTTP.Types
17+import Network.Wai
18+
19+type Path = [Text]
20+newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }
21+
22+instance Functor UrlMap' where
23+ fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)
24+
25+instance Applicative UrlMap' where
26+ pure x = UrlMap' [([], x)]
27+ (UrlMap' xs) <*> (UrlMap' ys) = UrlMap' [ (p, f y) |
28+ (p, y) <- ys,
29+ f <- map snd xs ]
30+
31+instance Alternative UrlMap' where
32+ empty = UrlMap' empty
33+ (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
34+
35+type UrlMap = UrlMap' Application
36+
37+-- | Mount an application under a given path.
38+mount' :: ToApplication a => Path -> a -> UrlMap
39+mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
40+
41+-- A little helper function, since most of the time, apps are mounted under
42+-- a single path segment.
43+mount :: ToApplication a => Text -> a -> UrlMap
44+mount prefix thing = mount' [prefix] thing
45+
46+-- Another little helper function. Use this for the last mounted
47+-- application in the block, to avoid 500 errors from none matching.
48+mountRoot :: ToApplication a => a -> UrlMap
49+mountRoot = mount' []
50+
51+try :: Eq a
52+ => [a] -- ^ Path info of request
53+ -> [([a], b)] -- ^ List of applications to match
54+ -> Maybe ([a], b)
55+try xs tuples = foldl go Nothing tuples
56+ where
57+ go (Just x) _ = Just x
58+ go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
59+
60+class ToApplication a where
61+ toApplication :: a -> Application
62+
63+instance ToApplication Application where
64+ toApplication = id
65+
66+instance ToApplication UrlMap where
67+ toApplication urlMap = \req ->
68+ case try (pathInfo req) (unUrlMap urlMap) of
69+ Just (newPath, app) ->
70+ app $ req { pathInfo = newPath
71+ , rawPathInfo = makeRaw newPath
72+ }
73+ Nothing ->
74+ return $ responseLBS
75+ status500
76+ [("content-type", "text/plain")]
77+ ("WaiUrlMapper: no routes matched. Consider using \
78+ \mountRoot for the last mapping in the 'do' block.\n")
79+
80+ where
81+ makeRaw :: [Text] -> B.ByteString
82+ makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
83+
84+mapUrls :: UrlMap -> Application
85+mapUrls = toApplication
wai-extra/test/WaiExtraTest.hs+65
@@ -9,6 +9,7 @@ import Blaze.ByteString.Builder (toByteString)
99import Network.Wai
1010import Network.Wai.Test
1111import Network.Wai.Parse
12+import Network.Wai.UrlMap
1213import qualified Data.ByteString as S
1314import qualified Data.ByteString.Char8 as S8
1415import qualified Data.ByteString.Lazy.Char8 as L8
@@ -17,6 +18,7 @@ import qualified Data.Text.Lazy as T
1718import qualified Data.Text as TS
1819import qualified Data.Text.Encoding as TE
1920import Control.Arrow
21+import Control.Applicative
2022import Control.Monad.Trans.Resource (getInternalState, withInternalState, runResourceT)
2123
2224import Network.Wai.Middleware.Jsonp
@@ -42,6 +44,9 @@ import qualified Data.IORef as I
4244
4345specs :: Spec
4446specs = do
47+ describe "Network.Wai.UrlMap" $ do
48+ mapM_ (uncurry it) casesUrlMap
49+
4550 describe "Network.Wai.Parse" $ do
4651 describe "parseContentType" $ do
4752 let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)
@@ -561,3 +566,63 @@ caseDebugRequestBody = do
561566
562567 {-debugApp = debug $ \req -> do-}
563568 {-return $ responseLBS status200 [ ] ""-}
569+
570+urlMapTestApp :: Application
571+urlMapTestApp = mapUrls $
572+ mount "bugs" bugsApp
573+ <|> mount "helpdesk" helpdeskApp
574+ <|> mount "api"
575+ ( mount "v1" apiV1
576+ <|> mount "v2" apiV2
577+ )
578+ <|> mountRoot mainApp
579+
580+ where
581+ trivialApp :: S.ByteString -> Application
582+ trivialApp name req =
583+ return $
584+ responseLBS
585+ status200
586+ [ ("content-type", "text/plain")
587+ , ("X-pathInfo", S8.pack . show . pathInfo $ req)
588+ , ("X-rawPathInfo", rawPathInfo req)
589+ , ("X-appName", name)
590+ ]
591+ ""
592+
593+ bugsApp = trivialApp "bugs"
594+ helpdeskApp = trivialApp "helpdesk"
595+ apiV1 = trivialApp "apiv1"
596+ apiV2 = trivialApp "apiv2"
597+ mainApp = trivialApp "main"
598+
599+casesUrlMap :: [(String, Assertion)]
600+casesUrlMap = [pair1, pair2, pair3, pair4]
601+ where
602+ makePair name session = (name, runSession session urlMapTestApp)
603+ get reqPath = request $ setPath defaultRequest reqPath
604+ s = S8.pack . show :: [TS.Text] -> S.ByteString
605+
606+ pair1 = makePair "should mount root" $ do
607+ res1 <- get "/"
608+ assertStatus 200 res1
609+ assertHeader "X-rawPathInfo" "/" res1
610+ assertHeader "X-pathInfo" (s []) res1
611+ assertHeader "X-appName" "main" res1
612+
613+ pair2 = makePair "should mount apps" $ do
614+ res2 <- get "/bugs"
615+ assertStatus 200 res2
616+ assertHeader "X-rawPathInfo" "/" res2
617+ assertHeader "X-pathInfo" (s []) res2
618+ assertHeader "X-appName" "bugs" res2
619+
620+ pair3 = makePair "should preserve extra path info" $ do
621+ res3 <- get "/helpdesk/issues/11"
622+ assertStatus 200 res3
623+ assertHeader "X-rawPathInfo" "/issues/11" res3
624+ assertHeader "X-pathInfo" (s ["issues", "11"]) res3
625+
626+ pair4 = makePair "should 500 if none match" $ do
627+ res4 <- get "/api/v3"
628+ assertStatus 500 res4
wai-extra/wai-extra.cabal+1
@@ -60,6 +60,7 @@ Library
6060 Network.Wai.Middleware.Vhost
6161 Network.Wai.Middleware.HttpAuth
6262 Network.Wai.Parse
63+ Network.Wai.UrlMap
6364 other-modules: Network.Wai.Middleware.RequestLogger.Internal
6465 ghc-options: -Wall
6566