wai-extra 2.0.1.2 → 2.0.2
raw patch · 4 files changed
+195/−19 lines, 4 files
Files
- Network/Wai/Middleware/RequestLogger.hs +23/−16
- Network/Wai/UrlMap.hs +103/−0
- test/WaiExtraTest.hs +67/−2
- wai-extra.cabal +2/−1
Network/Wai/Middleware/RequestLogger.hs view
@@ -82,7 +82,9 @@ callback <- case destination of Handle h -> return $ BS.hPutStr h . logToByteString- Logger l -> return $ pushLogStr l+ Logger l -> return $ \msg -> do+ pushLogStr l msg+ flushLogStr l Callback c -> return c case outputFormat of Apache ipsrc -> do@@ -177,13 +179,14 @@ return $ ansiColor color else return (return return) return $ detailedMiddleware' cb getAddColor- where- ansiColor color bs = [- pack $ setSGRCode [SetColor Foreground Vivid color]- , bs- , pack $ setSGRCode [Reset]- ] +ansiColor :: Color -> BS.ByteString -> [BS.ByteString]+ansiColor color bs = [+ pack $ setSGRCode [SetColor Foreground Vivid color]+ , bs+ , pack $ setSGRCode [Reset]+ ]+ detailedMiddleware' :: Callback -> IO (BS.ByteString -> [BS.ByteString]) -> Middleware@@ -225,14 +228,14 @@ let getParams = map emptyGetParam $ queryString req addColor <- getAddColor+ let accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req -- log the request immediately. liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++ [ " " , rawPathInfo req- , "\n"- , "Accept: "- , fromMaybe "" $ lookup "Accept" $ requestHeaders req+ , " | "+ , accept , paramsToBS "GET " getParams , paramsToBS "POST " postParams , "\n"@@ -243,14 +246,14 @@ -- log the status of the response -- this is color coordinated with the request logging -- also includes the request path to connect it to the request- liftIO $ cb $ mconcat $ map toLogStr $ addColor "Status: " ++ [- statusBS rsp- , " "+ liftIO $ cb $ mconcat $ map toLogStr $+ addColor "Status: " ++ statusBS rsp +++ [ " " , msgBS rsp , ". " , rawPathInfo req -- if you need help matching the 2 logging statements , "\n"- ]+ ] return rsp where paramsToBS prefix params =@@ -275,8 +278,12 @@ (i, _):_ -> Just (i :: Int) [] -> Nothing -statusBS :: Response -> BS.ByteString-statusBS = pack . show . statusCode . responseStatus+statusBS :: Response -> [BS.ByteString]+statusBS rsp =+ if status > 400 then ansiColor Red bs else [bs]+ where+ bs = pack $ show status+ status = statusCode $ responseStatus rsp msgBS :: Response -> BS.ByteString msgBS = statusMessage . responseStatus
+ Network/Wai/UrlMap.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{- | This module gives you a way to mount applications under sub-URIs.+For example:++> bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application+>+> myApp :: Application+> myApp = mapUrls $+> mount "bugs" bugsApp+> <|> mount "helpdesk" helpdeskApp+> <|> mount "api"+> ( mount "v1" apiV1+> <|> mount "v2" apiV2+> )+> <|> mountRoot mainApp++-}+module Network.Wai.UrlMap (+ UrlMap',+ UrlMap,+ mount',+ mount,+ mountRoot,+ mapUrls+) where++import Control.Applicative+import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as B+import Network.HTTP.Types+import Network.Wai++type Path = [Text]+newtype UrlMap' a = UrlMap' { unUrlMap :: [(Path, a)] }++instance Functor UrlMap' where+ fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)++instance Applicative UrlMap' where+ pure x = UrlMap' [([], x)]+ (UrlMap' xs) <*> (UrlMap' ys) = UrlMap' [ (p, f y) |+ (p, y) <- ys,+ f <- map snd xs ]++instance Alternative UrlMap' where+ empty = UrlMap' empty+ (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> ys)++type UrlMap = UrlMap' Application++-- | Mount an application under a given path. The ToApplication typeclass gives+-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'+-- as the second argument.+mount' :: ToApplication a => Path -> a -> UrlMap+mount' prefix thing = UrlMap' [(prefix, toApplication thing)]++-- | A convenience function like mount', but for mounting things under a single+-- path segment.+mount :: ToApplication a => Text -> a -> UrlMap+mount prefix thing = mount' [prefix] thing++-- | Mount something at the root. Use this for the last application in the+-- block, to avoid 500 errors from none of the applications matching.+mountRoot :: ToApplication a => a -> UrlMap+mountRoot = mount' []++try :: Eq a+ => [a] -- ^ Path info of request+ -> [([a], b)] -- ^ List of applications to match+ -> Maybe ([a], b)+try xs tuples = foldl go Nothing tuples+ where+ go (Just x) _ = Just x+ go _ (prefix, y) = stripPrefix prefix xs >>= \xs' -> return (xs', y)++class ToApplication a where+ toApplication :: a -> Application++instance ToApplication Application where+ toApplication = id++instance ToApplication UrlMap where+ toApplication urlMap = \req ->+ case try (pathInfo req) (unUrlMap urlMap) of+ Just (newPath, app) ->+ app $ req { pathInfo = newPath+ , rawPathInfo = makeRaw newPath+ }+ Nothing ->+ return $ responseLBS+ status404+ [("content-type", "text/plain")]+ "Not found\n"++ where+ makeRaw :: [Text] -> B.ByteString+ makeRaw = ("/" `B.append`) . T.encodeUtf8 . T.intercalate "/"++mapUrls :: UrlMap -> Application+mapUrls = toApplication
test/WaiExtraTest.hs view
@@ -9,6 +9,7 @@ import Network.Wai import Network.Wai.Test import Network.Wai.Parse+import Network.Wai.UrlMap import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8@@ -17,6 +18,7 @@ import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow+import Control.Applicative import Control.Monad.Trans.Resource (getInternalState, withInternalState, runResourceT) import Network.Wai.Middleware.Jsonp@@ -42,6 +44,9 @@ specs :: Spec specs = do+ describe "Network.Wai.UrlMap" $ do+ mapM_ (uncurry it) casesUrlMap+ describe "Network.Wai.Parse" $ do describe "parseContentType" $ do let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)@@ -541,8 +546,8 @@ where params = [("foo", "bar"), ("baz", "bin")] -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)- postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"- getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"+ postOutput = T.pack $ "POST / | \nStatus: 200 OK. /\n"+ getOutput params' = T.pack $ "GET /location | \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" debugApp output' req = do iactual <- liftIO $ I.newIORef mempty@@ -561,3 +566,63 @@ {-debugApp = debug $ \req -> do-} {-return $ responseLBS status200 [ ] ""-}++urlMapTestApp :: Application+urlMapTestApp = mapUrls $+ mount "bugs" bugsApp+ <|> mount "helpdesk" helpdeskApp+ <|> mount "api"+ ( mount "v1" apiV1+ <|> mount "v2" apiV2+ )+ <|> mountRoot mainApp++ where+ trivialApp :: S.ByteString -> Application+ trivialApp name req =+ return $+ responseLBS+ status200+ [ ("content-type", "text/plain")+ , ("X-pathInfo", S8.pack . show . pathInfo $ req)+ , ("X-rawPathInfo", rawPathInfo req)+ , ("X-appName", name)+ ]+ ""++ bugsApp = trivialApp "bugs"+ helpdeskApp = trivialApp "helpdesk"+ apiV1 = trivialApp "apiv1"+ apiV2 = trivialApp "apiv2"+ mainApp = trivialApp "main"++casesUrlMap :: [(String, Assertion)]+casesUrlMap = [pair1, pair2, pair3, pair4]+ where+ makePair name session = (name, runSession session urlMapTestApp)+ get reqPath = request $ setPath defaultRequest reqPath+ s = S8.pack . show :: [TS.Text] -> S.ByteString++ pair1 = makePair "should mount root" $ do+ res1 <- get "/"+ assertStatus 200 res1+ assertHeader "X-rawPathInfo" "/" res1+ assertHeader "X-pathInfo" (s []) res1+ assertHeader "X-appName" "main" res1++ pair2 = makePair "should mount apps" $ do+ res2 <- get "/bugs"+ assertStatus 200 res2+ assertHeader "X-rawPathInfo" "/" res2+ assertHeader "X-pathInfo" (s []) res2+ assertHeader "X-appName" "bugs" res2++ pair3 = makePair "should preserve extra path info" $ do+ res3 <- get "/helpdesk/issues/11"+ assertStatus 200 res3+ assertHeader "X-rawPathInfo" "/issues/11" res3+ assertHeader "X-pathInfo" (s ["issues", "11"]) res3++ pair4 = makePair "should 404 if none match" $ do+ res4 <- get "/api/v3"+ assertStatus 404 res4
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 2.0.1.2+Version: 2.0.2 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT@@ -60,6 +60,7 @@ Network.Wai.Middleware.Vhost Network.Wai.Middleware.HttpAuth Network.Wai.Parse+ Network.Wai.UrlMap other-modules: Network.Wai.Middleware.RequestLogger.Internal ghc-options: -Wall