Commits

Luke Plant  committed 1eb03c0

Added experimental routing mechanism

  • Participants
  • Parent commits cc01453

Comments (0)

Files changed (2)

File src/Web/Framework.hs

                      , DispatchOptions(..)
                      , defaultDispatchOptions
                      , View
+                     , matchPath
                      )
 
 where
 
+import Data.List (isPrefixOf)
 import Web.Response
 import Web.Request
 import Web.Utils
 import System.IO (stdout, hClose)
 import qualified Data.ByteString.Lazy.Char8 as BS
 
+
+-- * Dispatching
+
 data DispatchOptions = DispatchOptions {
       notFoundHandler :: Request -> IO Response -- function that will return a 404 page in the case
                                                 -- of no view functions matching
             Nothing -> notFoundHandler opts $ req
             Just x -> return x
   BS.hPut stdout (formatResponse resp)
+
+-- * Routing mechanism
+
+matchPath :: String -> View -> View
+matchPath path view = \req -> if path `isPrefixOf` (pathInfo req)
+                              then view req
+                              else return Nothing

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

 import Web.Framework
 import Web.Request
 import Web.Response
-import Data.Maybe (isNothing)
+import Data.Maybe (isNothing, isJust)
 import Control.Monad (liftM)
 
-req1 = mkRequest [("REQUEST_METHOD","GET")] ""
+req1 = mkRequest [("REQUEST_METHOD","GET"),
+                  ("PATH_INFO", "/posts/")] ""
 resp1 = buildResponse utf8HtmlResponse [ addContent "resp1" ]
 resp2 = buildResponse utf8HtmlResponse [ addContent "resp2" ]
 
                          return $ (resp == (Just resp1) && resp /= (Just resp2)))
                        ~? "Dispatch should return first that succeeds"
 
+testMatchPath1 = (dispatchRequest req1 [matchPath "/foo/" alwaysSucceedView1]
+                  >>= return . isNothing)
+                 ~? "matchPath limits dispatching if path does not match"
+
+testMatchPath2 = (dispatchRequest req1 [matchPath "/posts/" alwaysSucceedView1]
+                  >>= return . isJust)
+                 ~? "matchPath allows dispatching if path does match"
+
 tests = test [
          testDispatchRequest1
         , testDispatchRequest2
         , testDispatchRequest3
+        , testMatchPath1
+        , testMatchPath2
         ]