From dcd7b9e5b8ea96acf398c15dc04f1f71fb050a89 Mon Sep 17 00:00:00 2001 From: Portnov Date: Wed, 22 Jul 2009 17:52:43 +0600 Subject: [PATCH] Small refactoring --- Blog/Blog.hs | 6 +--- Framework/API/Cache.hs | 9 +++++++ Framework/Cache/Cache.hs | 42 ++++++++++++++++---------------- Framework/Exceptions.hs | 16 ++++++++++-- Framework/Modules/Auth/Controllers.hs | 10 ++----- Framework/TEngine/TemplateUtil.hs | 8 +++--- 6 files changed, 52 insertions(+), 39 deletions(-) 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 -- 1.7.2.3