Commits

Luke Plant  committed 08d32ce

Reimplemented addSlashRedirect and canonicalUri as view functions instead of view processors

  • Participants
  • Parent commits d142efb

Comments (0)

Files changed (4)

File src/Blog/Processors.hs

 import qualified Blog.Settings as Settings
 
 
-canonicalUri view req =
+canonicalUri :: Request -> IO (Maybe Response)
+canonicalUri req =
     let uri' = requestUriRaw req
-    in case uri' of
-         Nothing -> view req
-         Just uri -> if Settings.prog_uri `isPrefixOf` uri
+    in return $ case uri' of
+                  Nothing -> Nothing
+                  Just uri -> if Settings.prog_uri `isPrefixOf` uri
                      then let canonUri = Settings.root_url ++ drop (length Settings.prog_uri + length "/") uri
-                          in return $ Just $ redirectResponse canonUri
-                     else view req
+                          in Just $ redirectResponse canonUri
+                     else Nothing

File src/Blog/Routes.hs

 import Blog.Views
 import Blog.Processors
 import Web.Framework
-import Web.Processors.General (addSlashRedirectProcessor)
+import Web.Processors.General (addSlashRedirectView)
 import Web.GenUtils (apply)
 
 -- * Routes
 
 -- These need to be manually synced with Blog.Links
 
-views' = [ empty                                      //-> mainIndex              $ []
+views  = [ addSlashRedirectView
+         , canonicalUri
+         , empty                                      //-> mainIndex              $ []
          , "posts/" <+/> stringParam                  //-> postView               $ []
          , "posts/" <+/> empty                        //-> postsRedirectView      $ []
          , "categories/" <+/> empty                   //-> categoriesView         $ []
          , "categories/" <+/> stringParam             //-> categoryView           $ []
          , "debug/" <+/> stringParam                  //-> debug                  $ []
          ]
-
--- 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
-        , canonicalUri
-        ]
-
-views = map (apply procs) views'

File src/Web/Processors/General.hs

 module Web.Processors.General
-    ( addSlashRedirectProcessor
+    ( addSlashRedirectView
     )
 
 where
 --  These are straightforward view functions which happen to work as a
 --  kind of pre-handler.  They are installed using routes, usually
 --  before all the others.  These usually do redirects, for example
---  addSlashRedirectProcessor
+--  addSlashRedirectView
 
 -- ** Response processors
 
 -- TODO
 -- need to include query string, and think about how to handle
 -- POSTs etc
-addSlashRedirectProcessor view req =
+addSlashRedirectView :: Request -> IO (Maybe Response)
+addSlashRedirectView req =
     let uri = requestUriRaw req
-    in case uri of
-        Nothing -> view req -- Can't do a redirect if we don't know original URI
-        Just "" -> view req -- Don't redirect if empty
-        Just x ->  if not ("/" `isSuffixOf` x)
-                   then return $ Just $ redirectResponse (x ++ "/")
-                   else view req
+    in return $ case uri of
+                  Nothing ->  Nothing -- Can't do a redirect if we don't know original URI
+                  Just "" ->  Nothing -- Don't redirect if empty
+                  Just x | ("/" `isSuffixOf` x) -> Nothing -- slash is already there
+                  Just x  ->  Just $ redirectResponse (x ++ "/")

File testsuite/tests/Tests/Web/Processors/General.hs

 import Web.Response
 import Web.Request
 import Test.HUnit
-import Tests.Web.Framework -- reuse view functions
+import Tests.Web.Framework (mkGetReq)
 
-testAddSlashRedirectProcessor1 =
+testAddSlashRedirectView1 =
     (do
-      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkGetReq "/posts")
+      resp <- addSlashRedirectView (mkGetReq "/posts")
       return (resp == (Just $ redirectResponse "/posts/"))
-    ) ~? "addSlashRedirectProcessor should add a slash if not present at end"
+    ) ~? "addSlashRedirectView should add a slash if not present at end"
 
 
-testAddSlashRedirectProcessor2 =
+testAddSlashRedirectView2 =
     (do
-      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkGetReq "/posts/")
-      return (resp == (Just resp1))
-    ) ~? "addSlashRedirectProcessor should not redirect if slash present at end"
+      resp <- addSlashRedirectView (mkGetReq "/posts/")
+      return (resp == Nothing)
+    ) ~? "addSlashRedirectView should not redirect if slash present at end"
 
-testAddSlashRedirectProcessor3 =
+testAddSlashRedirectView3 =
     (do
-      resp <- addSlashRedirectProcessor alwaysSucceedView1 (mkRequest
-                                                            [("REQUEST_METHOD", "GET")
-                                                            ,("PATH_INFO", "/posts")
-                                                            ,("REQUEST_URI","/foo/posts")]
-                                                            "" utf8Encoding)
+      resp <- addSlashRedirectView (mkRequest
+                                    [("REQUEST_METHOD", "GET")
+                                    ,("PATH_INFO", "/posts")
+                                    ,("REQUEST_URI","/foo/posts")]
+                                    "" utf8Encoding)
       return (resp == (Just $ redirectResponse "/foo/posts/"))
-    ) ~? "addSlashRedirectProcessor should redirect based on request URI, not path info"
+    ) ~? "addSlashRedirectView should redirect based on request URI, not path info"
 
 
 
-tests = test [ testAddSlashRedirectProcessor1
-             , testAddSlashRedirectProcessor2
-             , testAddSlashRedirectProcessor3
+tests = test [ testAddSlashRedirectView1
+             , testAddSlashRedirectView2
+             , testAddSlashRedirectView3
              ]