Commits

Luke Plant  committed 248b995

Added view decorator method that actually works

  • Participants
  • Parent commits 838dff0

Comments (0)

Files changed (3)

File src/Blog/Routes.hs

 
 -- These need to be manually synced with Blog.Links
 
-views' = [ empty                                      //-> mainIndex
-         , "posts/" <+/> stringParam                  //-> postView
-         , "posts/" <+/> empty                        //-> postsRedirectView
-         , "categories/" <+/> empty                   //-> categoriesView
-         , "categories/" <+/> stringParam             //-> categoryView
-         , "debug/" <+/> stringParam                  //-> debug
+views' = [ empty                                      //-> mainIndex              $ []
+         , "posts/" <+/> stringParam                  //-> postView               $ []
+         , "posts/" <+/> empty                        //-> postsRedirectView      $ []
+         , "categories/" <+/> empty                   //-> categoriesView         $ []
+         , "categories/" <+/> stringParam             //-> categoryView           $ []
+         , "debug/" <+/> stringParam                  //-> debug                  $ []
          ]
 
--- Apply global processors to all views
+-- Apply global processors to all views.  NB - these processors run
+-- even if the matcher will not succeed, so this should only be done
+-- for processors which either require this behaviour, or are low
+-- enough overhead to be done anyway.
 procs = [addSlashRedirectProcessor]
 
 views = map (apply procs) views'

File src/Web/Framework.hs

                      , View
                      -- * Routing mechanism
                      -- $routing
-                     , routeTo
+                     , route
                      , (//->)
                      -- * Matchers
                      , fixedString
 
 import Control.Monad ((>=>))
 import Data.List (isPrefixOf)
+import Web.GenUtils (apply)
 import Web.Response
 import Web.Request
 import System.IO (stdout, hClose)
 
 -- * Dispatching
 
-
 data DispatchOptions = DispatchOptions {
       notFoundHandler :: Request -> IO Response
     -- ^ function that will return a 404 page in the case of no view functions matching
                          , requestOptions = defaultRequestOptions
                          }
 
-
 -- Dispatching
 
 -- | Used by dispatchCGI, might be useful on its own, especially in testing
 -- The routing mechanism has been designed so that you can write code like the following:
 --
 -- > routes = [
--- >            empty                                  //-> indexView
--- >          , "posts/" <+/> empty                    //-> postsView
--- >          , intParam                               //-> viewWithIntParam
--- >          , stringParam                            //-> viewWithStringParam
--- >          , intParam </+> "test/"                  //-> viewWithIntParam
--- >          , "test/" <+/> intParam                  //-> viewWithIntParam
--- >          , intParam </> stringParam               //-> viewWithIntAndStringParam
--- >          , intParam </> stringParam </> intParam  //-> viewWithIntStringInt
+-- >            empty                                  //-> indexView                 $ decs
+-- >          , "posts/" <+/> empty                    //-> postsView                 $ []
+-- >          , intParam                               //-> viewWithIntParam          $ []
+-- >          , stringParam                            //-> viewWithStringParam       $ []
+-- >          , intParam </+> "test/"                  //-> viewWithIntParam          $ []
+-- >          , "test/" <+/> intParam                  //-> viewWithIntParam          $ []
+-- >          , intParam </> stringParam               //-> viewWithIntAndStringParam $ []
+-- >          , intParam </> stringParam </> intParam  //-> viewWithIntStringInt      $ []
 -- >          ]
 --
 -- where:
 -- >  viewWithIntParam :: Int -> Request -> IO (Maybe Response)
 -- >  viewWithIntAndStringParam :: Int -> String -> Request -> IO (Maybe Response)
 -- >  viewWithIntStringInt :: Int -> String -> Int -> Request -> IO (Maybe Response)
+-- >  decs :: [View -> View]
 --
 -- The right hand argument of //-> is a 'view like' function, of type
 -- View OR a -> View OR a -> b -> View etc,
 --
 -- > fixedString "thestring/"
 --
+-- The result of the //-> operator needs to be passed a list of \'view
+-- decorator\' functions, (which may be an empty list) e.g. \'decs\'
+-- above.  These decorators take a View and return a View, or
+-- alternatively they take a View and a Request and return an IO
+-- (Maybe Response).  These means they can be used to do
+-- pre-processing of the request, and post-processing of the response.
+--
 -- The routing mechanism is extensible -- just define your own matchers.
 --
 -- NB. The Request object trims any leading slash on the path to normalise
 -- it, and also to simplify this parsing stage, so do not attempt to match
 -- an initial leading slash.
---
--- Applying view decorator functions is also convenient with the following syntax:
---
--- > routes = [ "edit/post/" <+/> stringParam     //-> editPostView `with` [loginRequired]
--- >          , ...
--- >          ]
---
--- where the RHS of `with` takes a list of view transformation functions e.g.
---
--- > loginRequired :: View -> View
-
 
 -- | Match a string at the beginning of the path
 fixedString :: String -> (String, a) -> Maybe (String, a)
 -- | Apply a matcher to a View (or View-like function that takes
 -- additional parameters) to get a View that only responds to the
 -- matched URLs
-routeTo :: ((String, a) -> Maybe (String, View))
-        -> a
-        -> View
-routeTo matcher f = \req -> let match = matcher (pathInfo req, f)
-                            in case match of
-                                 Nothing -> return Nothing
-                                 Just (remainder, view) -> if null remainder
-                                                           then view req
-                                                           else return Nothing
--- | Alias for 'routeTo'
-(//->) = routeTo
+route :: ((String, a) -> Maybe (String, View)) -- ^ matcher
+      -> a                                     -- ^ view-like function
+      -> [View -> View]                        -- ^ optional view decorators (processors)
+      -> View
+route matcher f decs =
+    \req -> let match = matcher (pathInfo req, f)
+            in case match of
+                 Nothing -> return Nothing
+                 Just (remainder, view) -> if null remainder
+                                           then (apply decs view) req
+                                           else return Nothing
+-- | Alias for 'route'
+(//->) = route

File testsuite/tests/Tests/Web/Framework.hs

                          return $ (resp == (Just resp1) && resp /= (Just resp2)))
                        ~? "Dispatch should return first that succeeds"
 
-testFixedStringSucceed = ((fixedString "posts/" `routeTo` alwaysSucceedView1 $ req1)
+testFixedStringSucceed = ((route (fixedString "posts/") alwaysSucceedView1 [] $ req1)
                           >>= return . (== (Just resp1)))
                          ~? "fixedString should leave view as is if the path matches completely"
 
-testFixedStringFail = ((fixedString "bar/" `routeTo` alwaysSucceedView1 $ req1)
+testFixedStringFail = ((route (fixedString "bar/") alwaysSucceedView1 [] $ req1)
                           >>= return . isNothing)
                          ~? "fixedString should return Nothing if the path does not match"
 
-testRouteToAnyPath = ((anyPath `routeTo` alwaysSucceedView1 $ req1)
+testRouteToAnyPath = ((route anyPath alwaysSucceedView1 [] $ req1)
                       >>= return . (== Just resp1))
                      ~? "routeTo leaves a view alone if matcher always succeeds"
 
-testRouteToNotAllMatched = ((fixedString "po" `routeTo` alwaysSucceedView1 $ req1)
+testRouteToNotAllMatched = ((route (fixedString "po") alwaysSucceedView1 [] $ req1)
                             >>= return . isNothing)
                            ~? "routeTo does not route to a view if the match does not exhaust the path"
 
 routes = [
-           empty                                  //-> alwaysSucceedView1
-         , "posts/" <+/> empty                    //-> alwaysSucceedView2
-         , intParam                               //-> viewWithIntParam1
-         , stringParam                            //-> viewWithStringParam1
-         , intParam </+> "test/"                  //-> viewWithIntParam2
-         , "test/" <+/> intParam                  //-> viewWithIntParam2
+           empty                                  //-> alwaysSucceedView1         $ []
+         , "posts/" <+/> empty                    //-> alwaysSucceedView2         $ []
+         , intParam                               //-> viewWithIntParam1          $ []
+         , stringParam                            //-> viewWithStringParam1       $ []
+         , intParam </+> "test/"                  //-> viewWithIntParam2          $ []
+         , "test/" <+/> intParam                  //-> viewWithIntParam2          $ []
          -- NB line below has to come after 'intParam </+> "test/"' line
-         , intParam </> stringParam               //-> viewWithIntAndStringParam1
-         , intParam </> stringParam </> intParam  //-> viewWithIntStringInt1
+         , intParam </> stringParam               //-> viewWithIntAndStringParam1 $ []
+         , intParam </> stringParam </> intParam  //-> viewWithIntStringInt1      $ []
          ]
 
 testRoutes1 = (do