Small refactoring
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 6558785..aa27b36 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -48,16 +48,14 @@ i18ntest = do
text <- __ "Hello world!"
renderToResponseM "i18ntest.html" [("text", C text)]
-allposts2 = do
- methodOnly GET
+allposts2 = methodOnly GET $ do
(posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel
posts' <- selectRelated posts
renderToResponseM "posts2.html" [("posts", C posts'),
("pager", C pagerHtml)]
allposts :: HttpAction
-allposts = do
- methodOnly GET
+allposts = methodOnly GET $ do
page <- asks (_GET' "page" "1")
let key = "allposts" ++ page
tryReturnFromCache key
diff --git a/Framework/API/Cache.hs b/Framework/API/Cache.hs
index d927a36..ddea752 100644
--- a/Framework/API/Cache.hs
+++ b/Framework/API/Cache.hs
@@ -44,4 +44,13 @@ tryReturnFromCache key = do
returnNow $ ok content
Nothing -> return ()
+cached :: String
+ -> AController String
+ -> AController String
+cached key m = do
+ tryReturnFromCache key
+ result <- m
+ cachePut key result
+ return result
+
diff --git a/Framework/Cache/Cache.hs b/Framework/Cache/Cache.hs
index ecaade5..4efffa8 100644
--- a/Framework/Cache/Cache.hs
+++ b/Framework/Cache/Cache.hs
@@ -44,25 +44,25 @@ cDisconnect (CConnection b) = cfree b
-- | cached cConnection name key function argument
-- Executes given function with given argument, caching the result
-- (under given function name and item key)
-cached :: (Serializable k, Serializable v) => CacheConnection
- -> String -- ^ Cache variable (prefix of cache key)
- -> k -- ^ Key in the cache (suffix)
- -> (a -> v) -- ^ Function to cache
- -> a -- ^ Function's argument
- -> IO v
-cached (CConnection b) name k f x =
- do c <- cget b key
--- putStrLn $ "Server answer: "++(showC c)
- case c of
- Nothing -> putcache
- Just y -> if null (toString y)
- then putcache
- else {-do print (toString y) -}
- return y
- where key = name ++ ":" ++ (toString k)
- putcache = let y = f x
- in do cput b key y
--- putStrLn $ "No "++key++" in cache"
- return y
-
+-- cached :: (Serializable k, Serializable v) => CacheConnection
+-- -> String -- ^ Cache variable (prefix of cache key)
+-- -> k -- ^ Key in the cache (suffix)
+-- -> (a -> v) -- ^ Function to cache
+-- -> a -- ^ Function's argument
+-- -> IO v
+-- cached (CConnection b) name k f x =
+-- do c <- cget b key
+-- -- putStrLn $ "Server answer: "++(showC c)
+-- case c of
+-- Nothing -> putcache
+-- Just y -> if null (toString y)
+-- then putcache
+-- else {-do print (toString y) -}
+-- return y
+-- where key = name ++ ":" ++ (toString k)
+-- putcache = let y = f x
+-- in do cput b key y
+-- -- putStrLn $ "No "++key++" in cache"
+-- return y
+--
diff --git a/Framework/Exceptions.hs b/Framework/Exceptions.hs
index a245fc8..cb78373 100644
--- a/Framework/Exceptions.hs
+++ b/Framework/Exceptions.hs
@@ -74,13 +74,23 @@ errorIf code msg b =
then returnNow $ response code [] msg
else return ()
--- | Accept only given HTTP method, otherwise raise HTTP 400 error
-methodOnly :: RequestMethod
+-- | Assert only given HTTP method, otherwise raise HTTP 400 error
+assertMethod :: RequestMethod
-> AController ()
-methodOnly meth = do
+assertMethod meth = do
rq <- asks request
errorIf 400 "Invalid request method" $ rqMethod rq /= meth
+-- | Run controller only if request method is as given, else raise HTTP 400 error
+methodOnly :: RequestMethod
+ -> AController a
+ -> AController a
+methodOnly meth ctr = do
+ rq <- asks request
+ if rqMethod rq == meth
+ then ctr
+ else raiseC 400 "Invalid request method"
+
-- | Run a controller only if given HTTP method, otherwise return default value
ifMethod :: RequestMethod --
-> a -- ^ Default value
diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs
index b9d0458..e8b462e 100644
--- a/Framework/Modules/Auth/Controllers.hs
+++ b/Framework/Modules/Auth/Controllers.hs
@@ -15,9 +15,8 @@ checkAuth' :: String -- ^ Where to redirect if login ok
-> String -- ^ Where to redirect if login failed
-> Form -- ^ Login form
-> HttpAction
-checkAuth' target retry form = do
+checkAuth' target retry form = methodOnly POST $ do
rq <- asks request
- methodOnly POST
let model = formModel form
(d,_) = getForm form rq $ formName form
case d of
@@ -26,9 +25,7 @@ checkAuth' target retry form = do
let name = user -:> "name"
pass = user -:> "password"
objs <- querySQL' ((table model) `restrict` ("name" :==: "?")) [name] model
- if length objs /= 1
- then loginFailed
- else return ()
+ when (length objs /= 1) loginFailed
let dbuser = head objs
dbpass = fromSql $ dbuser -:> "password"
if dbpass == (sha1 $ fromSql pass)
@@ -84,8 +81,7 @@ loginPage = loginPage' defaultLoginForm
-- | Log out current user
doLogout :: String -- ^ Where to redirect after logout
-> HttpAction
-doLogout target = do
- methodOnly GET
+doLogout target = methodOnly GET $ do
send "logout" emptyModel
sessionUnset "username"
return $ redirect target
diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs
index a069dbd..d9cd257 100644
--- a/Framework/TEngine/TemplateUtil.hs
+++ b/Framework/TEngine/TemplateUtil.hs
@@ -47,7 +47,7 @@ renderToResponseP key name pairs = do
return ()
return $ ok html
-renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> Context -> IO HttpResponse
-renderToResponseC (ActionConfig{cacheBackend=b}) key name pairs = do
- v <- cached b ("render:"++name) key (render name) (M.fromList pairs)
- return $ ok v
+-- renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> Context -> IO HttpResponse
+-- renderToResponseC (ActionConfig{cacheBackend=b}) key name pairs = do
+-- v <- cached b ("render:"++name) key (render name) (M.fromList pairs)
+-- return $ ok v