Permalink
Browse files

Add the option to pass arguments to routes

N arguments can be passed to routes, and each of these arguments is then
passed to all Application before they are applied to any arguments
coming from the URI.  This allows IORefs, network connections to
databases, and other such things from IO to be passed to each action.
  • Loading branch information...
1 parent 7b612da commit 4ce0dc65f9860a96fd3dffc5809bf598cecefb7d @singpolyma committed Aug 9, 2012
Showing with 39 additions and 26 deletions.
  1. +6 −6 example/Application.hs
  2. +6 −1 example/Main.hs
  3. +1 −1 example/Makefile
  4. +26 −18 routeGenerator.hs
View
@@ -17,13 +17,13 @@ textToUTF8 txt = LZ.fromChunks [T.encodeUtf8 txt]
showUTF8 :: (Show a) => a -> LZ.ByteString
showUTF8 = textToUTF8 . T.pack . show
-home _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] "Hello World"
+on404 _ = return $ responseLBS notFound404 [("Content-Type", "text/plain")] "Not Found"
-test val _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] (textToUTF8 val)
+home _ _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] "Hello World"
-on404 _ = return $ responseLBS notFound404 [("Content-Type", "text/plain")] "Not Found"
+test _ val _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] (textToUTF8 val)
-test2 :: Integer -> Application
-test2 val _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] (showUTF8 val)
+test2 :: String -> Integer -> Application
+test2 _ val _ = return $ responseLBS ok200 [("Content-Type", "text/plain")] (showUTF8 val)
-test3 val env = return $ responseLBS ok200 [("Content-Type", "text/plain")] (textToUTF8 val `mappend` "\n\n" `mappend` showUTF8 (pathInfo env))
+test3 some val env = return $ responseLBS ok200 [("Content-Type", "text/plain")] (textToUTF8 val `mappend` "\n\n" `mappend` showUTF8 (pathInfo env) `mappend` "\n\n" `mappend` showUTF8 some)
View
@@ -8,6 +8,11 @@ import Network.Wai.Dispatch
import Application
import Routes
+-- Normally you wouldn't do this with pure values
+-- The arguments to routes are indended for things from IO that cannot
+-- be global like this
+something = "Woo, pass this around because we can!"
+
main = do
putStrLn "Running..."
- run 3000 (logStdoutDev $ dispatch on404 routes)
+ run 3000 (logStdoutDev $ dispatch on404 $ routes something)
View
@@ -2,4 +2,4 @@ Main: Main.hs Application.hs Routes.hs
ghc $^
Routes.hs: routes
- ../dist/build/routeGenerator/routeGenerator $^ Application > $@
+ ../dist/build/routeGenerator/routeGenerator $^ Application 1 > $@
View
@@ -26,15 +26,20 @@ instance Show Piece where
show Dynamic = "Dynamic"
show (Static s) = "Static (pack " ++ show (T.unpack s) ++ ")"
-emitRoutes :: [Route] -> IO ()
-emitRoutes rs = do
+emitRoutes :: [Route] -> Int -> IO ()
+emitRoutes rs nArgs = do
-- We want to be polymorphic in the parameter to route, so just let
-- the inference engine do it all
-- putStrLn "routes :: [Route a]"
- putStrLn "routes = ["
+ putStr "routes "
+ putStr $ unwords args
+ putStrLn " = ["
putStrLn $ intercalate ",\n" $ map showRoute rs
putStrLn "\t]"
where
+ args = args' nArgs
+ args' 0 = []
+ args' n = ("arg" ++ show n) : args' (n-1)
showRoute r =
"\t\tRoute {\n" ++
"\t\t\trhPieces = " ++
@@ -47,8 +52,9 @@ emitRoutes rs = do
"\t\t\trhDispatch = (\\(" ++
piecesPattern (pieces r) ++
- ") -> (return " ++
+ ") -> (return $ " ++
T.unpack (target r) ++
+ " " ++ unwords args ++
")" ++
piecesAp (pieces r) ++
")\n" ++
@@ -94,18 +100,20 @@ parser = many1 $ do
main :: IO ()
main = do
args <- getArgs
- case args of
- [input, mod] -> do
- Right routes <- fmap (parseOnly parser) $ T.readFile input
+ main' args
+ where
+ main' [input, mod, nArgs] = do
+ Right routes <- fmap (parseOnly parser) $ T.readFile input
- putStrLn "module Routes where"
- putStrLn ""
- putStrLn $ "import " ++ mod
- putStrLn "import Control.Monad (ap)"
- putStrLn "import Data.Text (pack)"
- putStrLn "import Web.PathPieces (fromPathPiece)"
- putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"
- putStrLn ""
- emitRoutes routes
- _ ->
- hPutStrLn stderr "Usage: ./routeGenerator <input file> <implementation module>"
+ putStrLn "module Routes where"
+ putStrLn ""
+ putStrLn $ "import " ++ mod
+ putStrLn "import Control.Monad (ap)"
+ putStrLn "import Data.Text (pack)"
+ putStrLn "import Web.PathPieces (fromPathPiece)"
+ putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"
+ putStrLn ""
+ emitRoutes routes (read nArgs)
+ main' [input, mod] = main' [input, mod, "0"]
+ main' _ =
+ hPutStrLn stderr "Usage: ./routeGenerator <input file> <implementation module> [<number of extra args>]"

0 comments on commit 4ce0dc6

Please sign in to comment.