git.iko.soy/typeable/wai
on master help sign in
Merge pull request #213 from hdgarrood/master

Add Network.Wai.UrlMap

commit96e62fdc3f2225e0bd2fe8cc35dfb3077bef3601 authorGreg Weber <greg@gregweber.info> dateSun 5 Jan 2014, 06:51 (13 years ago) parente7a3a6a4b348b6
3 files changed+169
compare with master
unifiedsplit
wai-extra/Network/Wai/UrlMap.hs+103 wai-extra/test/WaiExtraTest.hs+65 wai-extra/wai-extra.cabal+1
wai-extra/Network/Wai/UrlMap.hsnew file+103
@@ -0,0 +1,103 @@
1+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
2+{- | This module gives you a way to mount applications under sub-URIs.
3+For example:
4+
5+> bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application
6+>
7+> myApp :: Application
8+> myApp = mapUrls $
9+> mount "bugs" bugsApp
10+> <|> mount "helpdesk" helpdeskApp
11+> <|> mount "api"
12+> ( mount "v1" apiV1
13+> <|> mount "v2" apiV2
14+> )
15+> <|> mountRoot mainApp
16+
17+-}
18+module Network.Wai.UrlMap (
19+ UrlMap',
20+ UrlMap,
21+ mount',
22+ mount,
23+ mountRoot,
24+ mapUrls
25+) where
26+
27+import Control.Applicative
28+import Data.List
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import qualified Data.Text.Encoding as T
32+import qualified Data.ByteString as B
33+import Network.HTTP.Types
34+import Network.Wai
35+
36+type Path = [Text]
37+newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }
38+
39+instance Functor UrlMap' where
40+ fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)
41+
42+instance Applicative UrlMap' where
43+ pure x = UrlMap' [([], x)]
44+ (UrlMap' xs) <*> (UrlMap' ys) = UrlMap' [ (p, f y) |
45+ (p, y) <- ys,
46+ f <- map snd xs ]
47+
48+instance Alternative UrlMap' where
49+ empty = UrlMap' empty
50+ (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)
51+
52+type UrlMap = UrlMap' Application
53+
54+-- | Mount an application under a given path. The ToApplication typeclass gives
55+-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
56+-- as the second argument.
57+mount' :: ToApplication a => Path -> a -> UrlMap
58+mount' prefix thing = UrlMap' [(prefix, toApplication thing)]
59+
60+-- | A convenience function like mount', but for mounting things under a single
61+-- path segment.
62+mount :: ToApplication a => Text -> a -> UrlMap
63+mount prefix thing = mount' [prefix] thing
64+
65+-- | Mount something at the root. Use this for the last application in the
66+-- block, to avoid 500 errors from none of the applications matching.
67+mountRoot :: ToApplication a => a -> UrlMap
68+mountRoot = mount' []
69+
70+try :: Eq a
71+ => [a] -- ^ Path info of request
72+ -> [([a], b)] -- ^ List of applications to match
73+ -> Maybe ([a], b)
74+try xs tuples = foldl go Nothing tuples
75+ where
76+ go (Just x) _ = Just x
77+ go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)
78+
79+class ToApplication a where
80+ toApplication :: a -> Application
81+
82+instance ToApplication Application where
83+ toApplication = id
84+
85+instance ToApplication UrlMap where
86+ toApplication urlMap = \req ->
87+ case try (pathInfo req) (unUrlMap urlMap) of
88+ Just (newPath, app) ->
89+ app $ req { pathInfo = newPath
90+ , rawPathInfo = makeRaw newPath
91+ }
92+ Nothing ->
93+ return $ responseLBS
94+ status404
95+ [("content-type", "text/plain")]
96+ "Not found\n"
97+
98+ where
99+ makeRaw :: [Text] -> B.ByteString
100+ makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"
101+
102+mapUrls :: UrlMap -> Application
103+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 404 if none match" $ do
627+ res4 <- get "/api/v3"
628+ assertStatus 404 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