diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index b7a68e6..da29b47 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -3,9 +3,11 @@ import System.IO
import Database.HDBC (SqlValue(..),fromSql)
import qualified Data.Map as M
import Control.Monad
+import Control.Monad.Reader.Class
import Network.HTTP
import Framework.Types
+import Framework.Controller
import Framework.API
import Framework.SQL
import Framework.Http.Response
@@ -33,22 +35,25 @@ urlconf = "blog" // "new" --> newpost
<|> RawFunction serveStatic
testform :: HttpAction
-testform conf = do
- case rqMethod $ request conf of
+testform = do
+ rq <- asks request
+ case rqMethod rq of
GET -> return $ renderToResponse "testform.html" []
POST -> do
- print $ request conf
- print $ rqBody $ request conf
+ liftC $ print $ _POST rq
return $ redirect "/blog/"
allposts :: HttpAction
-allposts conf = do
- result <- cGet (cacheBackend conf) key
+allposts = do
+ rq <- asks request
+ let getvars = _GET rq
+ key = "allposts" ++ (getString' getvars "page" "1")
+ result <- cacheGet key
case result of
Just html -> return $ ok html
Nothing -> do
- (posts,pagerHtml) <- pager conf 5 (countChildren postModel commentModel "dt") [] postModel
- lastComments <- querySQL' conf ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel
+ (posts,pagerHtml) <- pager 5 (countChildren postModel commentModel "dt") [] postModel
+ lastComments <- querySQL' ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel
let code = getString' getvars "code" ""
let message = maybe "" id $ lookup code messagecodes
let html = render "blogposts.html" $
@@ -56,89 +61,90 @@ allposts conf = do
("comments", C lastComments),
("message", C message),
("pager", C pagerHtml)]
- cPut (cacheBackend conf) key html
+ cachePut key html
return $ ok html
- where key = "allposts" ++ (getString' getvars "page" "1")
- getvars = _GET (request conf)
-invalidatePostsCache :: ActionConfig -> IO ()
-invalidatePostsCache conf = do
- [[r]] <- queryListSQL conf (count (table postModel)) []
+invalidatePostsCache :: Controller ActionConfig ()
+invalidatePostsCache = do
+ [[r]] <- queryListSQL (count (table postModel)) []
let n = fromSql r :: Int
let pages = (n `div` 5) + 1
- forM [1..pages] $ \page -> cUnset (cacheBackend conf) ("allposts"++(show page))
+ forM [1..pages] $ \page -> cacheUnset ("allposts"++(show page))
return ()
newpost :: HttpAction
-newpost conf = do
- case rqMethod (request conf) of
+newpost = do
+ rq <- asks request
+ let url = myUrl rq
+ case rqMethod rq of
GET ->
- do (form,err) <- retryForm conf postForm "1" [] url
+ do (form,err) <- retryForm postForm "1" [] url
return $ renderToResponse "newpost.html" [("form", C form),
("invalid", C err)]
POST -> do
- let (d,_) = getForm allForms (request conf) "postform"
+ let (d,_) = getForm allForms rq "postform"
case d of
Right post -> let ptitle = post -:> "title"
pbody = post -:> "body"
- in do queryListSQL conf (insertM postModel) [ptitle, pbody]
- commit conf
- invalidatePostsCache conf
+ in do queryListSQL (insertM postModel) [ptitle, pbody]
+ commit
+ invalidatePostsCache
return $ redirectG "/blog/" ["code" := "1"]
- Left e -> returnInvalidForm conf postForm "1" e
- where url = myUrl (request conf)
+ Left e -> returnInvalidForm postForm "1" e
editpost :: StrAction
-editpost conf sid = Just $
- case rqMethod (request conf) of
+editpost sid = do
+ rq <- asks request
+ let url = myUrl rq
+ pid = read sid
+ case rqMethod rq of
GET ->
- do posts <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel
+ do posts <- querySQL' ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel
let post = head posts
let ptitle = post -:> "title"
let pbody = post -:> "body"
- (form,err) <- retryEditForm conf postForm "1" [("title",fromSql ptitle), ("body",fromSql pbody)] [] url
+ (form,err) <- retryEditForm postForm "1" [("title",fromSql ptitle), ("body",fromSql pbody)] [] url
return $ renderToResponse "editpost.html" [("form", C form),
("invalid", C err)]
POST -> do
- let (d,_) = getForm allForms (request conf) "postform"
+ let (d,_) = getForm allForms rq "postform"
case d of
Right post -> let ptitle = post -:> "title"
pbody = post -:> "body"
- in do queryListSQL conf (updateM postModel ("id":==:sid)) [ptitle, pbody]
- commit conf
- invalidatePostsCache conf
+ in do queryListSQL (updateM postModel ("id":==:sid)) [ptitle, pbody]
+ commit
+ invalidatePostsCache
return $ redirectG "/blog/" ["code" := "3"]
- Left e -> do cont <- returnInvalidForm conf postForm "1" e
+ Left e -> do cont <- returnInvalidForm postForm "1" e
return cont
- where url = myUrl (request conf)
- pid = read sid
onepost :: StrAction
-onepost conf sid = Just $ do
- (form,err) <- retryForm conf commentForm "1" [] url
- case rqMethod (request conf) of
+onepost sid = do
+ rq <- asks request
+ let url = myUrl rq
+ pid = read sid
+ (form,err) <- retryForm commentForm "1" [] url
+ case rqMethod rq of
GET -> do
- post <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel
- comments <- querySQL' conf ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 pid] commentModel
- let code = httpGetVar' (request conf) "code" ""
+ post <- querySQL' ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel
+ assertC $ (length post)==1
+ comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 pid] commentModel
+ let code = httpGetVar' rq "code" ""
let message = maybe "" id $ lookup code messagecodes
return $ renderToResponse "onepost.html" [("post", C (head post)),
("comments", C comments),
("message", C message),
("form", C form)]
POST -> do
- let (d,_) = getForm allForms (request conf) "comment"
+ let (d,_) = getForm allForms rq "comment"
case d of
Right comment ->
- do print $ mFields comment
+ do liftC $ print $ mFields comment
let cAuthor = comment -:> "author"
let cBody = comment -:> "body"
- queryListSQL conf (insertM commentModel) [SqlInt32 pid, cAuthor, cBody]
- commit conf
+ queryListSQL (insertM commentModel) [SqlInt32 pid, cAuthor, cBody]
+ commit
return $ redirectG url ["code" := "2"]
- Left e -> returnInvalidForm conf commentForm "1" e
- where url = myUrl (request conf)
- pid = read sid
-
+ Left e -> returnInvalidForm commentForm "1" e
main = serveHttp "blog.conf" urlconf
diff --git a/Framework/API.hs b/Framework/API.hs
index c117d4a..e8791f1 100644
--- a/Framework/API.hs
+++ b/Framework/API.hs
@@ -3,6 +3,7 @@
-- API functions get ActionConfig parameter, which contains all data about current job.
module Framework.API
(ActionConfig (..),
+ cacheGet, cachePut, cacheUnset,
serveHttp, serveStatic,
sessionLookup, sessionSet,
queryList, queryList', query, query',
@@ -14,11 +15,13 @@ module Framework.API
import Debug.Trace
+import Control.Monad.Reader.Class
import qualified Database.HDBC as HDBC
import qualified Data.Map as M
import Network.HTTP
import Framework.Types
+import Framework.Controller
import qualified Framework.Utils as Utils
import qualified Framework.Http.Cookies as Cookies
import qualified Framework.Http.Sessions as Sessions
@@ -32,65 +35,106 @@ import Framework.Http.Response ((<+>))
import Framework.Http.HTTPServer (serveHttp,serveStatic)
----------------------------------------------------------------------------------------------------------
+-- * Cache API
+
+cacheGet :: String -> Controller ActionConfig (Maybe String)
+cacheGet key = do
+ cb <- asks cacheBackend
+ liftC $ Cache.cGet cb key
+
+cachePut :: String -> String -> Controller ActionConfig Bool
+cachePut key value = do
+ cb <- asks cacheBackend
+ liftC $ Cache.cPut cb key value
+
+cacheUnset :: String -> Controller ActionConfig Bool
+cacheUnset key = do
+ cb <- asks cacheBackend
+ liftC $ Cache.cUnset cb key
+
+----------------------------------------------------------------------------------------------------------
-- * Sessions API
-- | Get variable from session
-sessionLookup :: ActionConfig -> String -> IO String
-sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup name sessionMap
+sessionLookup :: String -> Controller ActionConfig String
+sessionLookup name = do
+ mm <- asks sessionMap
+ return $ maybe "" id $ M.lookup name mm
-- | Set variable into session
-sessionSet :: ActionConfig -> String -> String -> IO ()
-sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value =
- Sessions.sPush sessionsBackend sessionID mm
- where mm = M.insert name value sessionMap
+sessionSet :: String -> String -> Controller ActionConfig ()
+sessionSet name value = do
+ ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask
+ liftC $ Sessions.sPush sessionsBackend sessionID $ M.insert name value sessionMap
----------------------------------------------------------------------------------------------------------
-- * Storage API
-- | Simple DB query. Lazy.
-queryList :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
-queryList ac sql params = Storage.query (dbconnection ac) sql params
+queryList :: String -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]]
+queryList sql params = do
+ conn <- asks dbconnection
+ liftC $ Storage.query conn sql params
-- | Just as "queryList", but strict.
-queryList' :: ActionConfig -> String -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
-queryList' ac sql params = Storage.query' (dbconnection ac) sql params
+queryList' :: String -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]]
+queryList' sql params = do
+ conn <- asks dbconnection
+ liftC $ Storage.query' conn sql params
-- | DB query. Returns list of Models.
-query :: ActionConfig
- -> String -- ^ SQL
+query :: String -- ^ SQL
-> [HDBC.SqlValue] -- ^ SQL parameters
-> Model -- ^ Model of query results
- -> IO [Model]
-query ac sql params model = Storage.queryR (dbconnection ac) sql params model
+ -> Controller ActionConfig [Model]
+query sql params model = do
+ conn <- asks dbconnection
+ liftC $ Storage.queryR conn sql params model
-- | Same as "query", but strict.
-query' :: ActionConfig -> String -> [HDBC.SqlValue] -> Model -> IO [Model]
-query' ac sql params model = Storage.queryR' (dbconnection ac) sql params model
+query' :: String -- ^ SQL
+ -> [HDBC.SqlValue] -- ^ SQL parameters
+ -> Model -- ^ Model of query results
+ -> Controller ActionConfig [Model]
+query' sql params model = do
+ conn <- asks dbconnection
+ liftC $ Storage.queryR' conn sql params model
-commit :: ActionConfig -> IO ()
-commit ac = Storage.commit (dbconnection ac)
+commit :: Controller ActionConfig ()
+commit = do
+ conn <- asks dbconnection
+ liftC $ Storage.commit conn
----------------------------------------------------------------------------------------------------------
-- * Storage/SQL API
-- | Same as "queryList", but gets SQL.Query instead of plain SQL
-queryListSQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
-queryListSQL ac q params = Storage.query (dbconnection ac) (SQL.sql q) params
+queryListSQL :: SQL.Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]]
+queryListSQL q params = do
+ conn <- asks dbconnection
+ liftC $ Storage.query conn (SQL.sql q) params
-- | Same, but strict.
-queryListSQL' :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> IO [[HDBC.SqlValue]]
-queryListSQL' ac q params = Storage.query' (dbconnection ac) (SQL.sql q) params
+queryListSQL' :: SQL.Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]]
+queryListSQL' q params = do
+ conn <- asks dbconnection
+ liftC $ Storage.query' conn (SQL.sql q) params
-- | Same as "query", but gets SQL.Query object instead of plain SQL
-querySQL :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> Model -> IO [Model]
-querySQL ac q params model = Storage.queryR (dbconnection ac) (SQL.sql q) params model
+querySQL :: SQL.Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model]
+querySQL q params model = do
+ conn <- asks dbconnection
+ liftC $ Storage.queryR conn (SQL.sql q) params model
-- | Same, but strict.
-querySQL' :: ActionConfig -> SQL.Query -> [HDBC.SqlValue] -> Model -> IO [Model]
-querySQL' ac q params model = Storage.queryR' (dbconnection ac) (SQL.sql q) params model
+querySQL' :: SQL.Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model]
+querySQL' q params model = do
+ conn <- asks dbconnection
+ liftC $ Storage.queryR' conn (SQL.sql q) params model
----------------------------------------------------------------------------------------------------------
-- * Cookies API
+-- FIXME: should this functions be monadic?
-- | Get cookie value
getcookie :: ActionConfig -> String -> String
@@ -104,14 +148,18 @@ setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value
-- * Logger API
-- | Write a message to access log
-accessLog :: ActionConfig
- -> String -- ^ Log message
- -> IO ()
-accessLog ac msg = Logger.writeLog (logChan $ httpParams ac) (request ac) msg
+accessLog :: String -- ^ Log message
+ -> Controller ActionConfig ()
+accessLog msg = do
+ chan <- asks (logChan.httpParams)
+ rq <- asks request
+ liftC $ Logger.writeLog chan rq msg
-- | Write a message to errors log
-errorLog :: ActionConfig
- -> String -- ^ Log message
- -> IO ()
-errorLog ac msg = Logger.writeLog (errChan $ httpParams ac) (request ac) msg
+errorLog :: String -- ^ Log message
+ -> Controller ActionConfig ()
+errorLog msg = do
+ chan <- asks (errChan.httpParams)
+ rq <- asks request
+ liftC $ Logger.writeLog chan rq msg
diff --git a/Framework/Controller.hs b/Framework/Controller.hs
new file mode 100644
index 0000000..95a2f07
--- /dev/null
+++ b/Framework/Controller.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Framework.Controller where
+
+import Control.Monad.Reader.Class
+
+import Framework.Types
+
+data ControllerResult a = RejectUrl
+ | RightNow HttpResponse
+ | Result a
+
+newtype Controller s a = Controller {
+ runController :: s -> IO (ControllerResult a) }
+
+type HttpController = Controller ActionConfig HttpResponse
+type StaticController = Controller StaticConfig HttpResponse
+
+anyResult :: ControllerResult HttpResponse -> Maybe HttpResponse
+anyResult RejectUrl = Nothing
+anyResult (RightNow r) = Just r
+anyResult (Result r) = Just r
+
+instance Monad (Controller s) where
+-- return :: a -> Controller s a
+ return v = Controller $ \_ -> return (Result v)
+
+-- (>>=) :: Controller s a -> (a -> Controller s b) -> Controller s b
+ Controller cmd >>= f =
+ Controller $ \s -> do -- `do` in IO
+ res <- cmd s
+ case res of
+ RejectUrl -> return RejectUrl
+ RightNow resp -> return $ RightNow resp
+ Result res' -> (runController . f) res' s
+
+instance MonadReader s (Controller s) where
+ ask = Controller $ \s -> return (Result s)
+ local f m = Controller $ runController m . f
+
+liftC :: IO a -> Controller s a
+liftC act = Controller $ \_ -> Result `fmap` act
+
+assertC :: Bool -> Controller s ()
+assertC b =
+ if b
+ then return ()
+ else rejectUrl
+
+returnNow :: HttpResponse -> Controller s ()
+returnNow v = Controller $ \_ -> return (RightNow v)
+
+rejectUrl :: Controller s a
+rejectUrl = Controller $ \_ -> return RejectUrl
+
+evalController :: Controller s HttpResponse -> s -> IO (Maybe HttpResponse)
+evalController m s = anyResult `fmap` (runController m s)
+
+
diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs
index 218718c..069887f 100644
--- a/Framework/Forms/Validation.hs
+++ b/Framework/Forms/Validation.hs
@@ -11,6 +11,7 @@ module Framework.Forms.Validation
import Debug.Trace
+import Control.Monad.Reader.Class
import qualified Data.Map as M
import Data.Maybe
@@ -19,6 +20,7 @@ import qualified Database.HDBC as D
import Framework.Types
import Framework.Utils
+import Framework.Controller
import Framework.Urls (myUrl)
import Framework.API
import Framework.Models
@@ -64,47 +66,47 @@ refillFormU :: [String]-> Form-> String-> [(String, String)]-> [(String, String)
refillFormU = refillFormG (\x y z -> z)
-- | Generate a form, maybe filled with already-entered data
-retryForm :: ActionConfig
- -> Form -- ^ A form
- -> String -- ^ Form ID
- -> [(String,String)] -- ^ Hidden values
- -> String -- ^ Target URL
- -> IO (String, String) -- ^ (Form HTML, error message)
-retryForm conf form fid pairs action = do
- filled <- sessionLookup conf "filled"
+retryForm :: Form -- ^ A form
+ -> String -- ^ Form ID
+ -> [(String,String)] -- ^ Hidden values
+ -> String -- ^ Target URL
+ -> Controller ActionConfig (String, String) -- ^ (Form HTML, error message)
+retryForm form fid pairs action = do
+ filled <- sessionLookup "filled"
+ rq <- asks request
-- putStrLn $ "retryForm: Session read: "++(show filled)
let defvals = decodePairs filled
-- putStrLn $ "retryForm: defvals: "++(show defvals)
- let err = httpGetVar' (request conf) "invalid" ""
+ let err = httpGetVar' rq "invalid" ""
if null err
then return (formToHtml $ createform form fid pairs action, "")
else return (formToHtml $ refillForm (words err) form fid pairs defvals action, err)
-retryEditForm :: ActionConfig
- -> Form -- ^ A form
- -> String -- ^ Form ID
- -> [(String,String)] -- ^ Default values
- -> [(String,String)] -- ^ Hidden values
- -> String -- ^ Target URL
- -> IO (String, String) -- ^ (Form HTML, error message)
-retryEditForm conf form fid defvals hidden action = do
- filled <- sessionLookup conf "filled"
+retryEditForm :: Form -- ^ A form
+ -> String -- ^ Form ID
+ -> [(String,String)] -- ^ Default values
+ -> [(String,String)] -- ^ Hidden values
+ -> String -- ^ Target URL
+ -> Controller ActionConfig (String, String) -- ^ (Form HTML, error message)
+retryEditForm form fid defvals hidden action = do
+ filled <- sessionLookup "filled"
+ rq <- asks request
let filledVals = decodePairs filled
- let err = httpGetVar' (request conf) "invalid" ""
+ let err = httpGetVar' rq "invalid" ""
if null err
then return (formToHtml $ refillFormU [] form fid hidden defvals action, "")
else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err)
-returnInvalidForm :: ActionConfig
- -> Form
+returnInvalidForm :: Form
-> String -- ^ Form ID
-> [String] -- ^ List of erroneus filled fields
- -> IO HttpResponse
-returnInvalidForm conf form fid errs =
- do sessionSet conf "filled" values
- return $ redirectG (myUrl $ request conf) ["invalid" := (unwords errs)]
- where values = tail $ urlencode $ map packParam vars
- vars = formVars form fid (request conf)
+ -> HttpController
+returnInvalidForm form fid errs = do
+ rq <- asks request
+ let values = tail $ urlencode $ map packParam vars
+ vars = formVars form fid rq
+ sessionSet "filled" values
+ return $ redirectG (myUrl rq) ["invalid" := (unwords errs)]
isRight :: Either t1 t -> Bool
isRight (Right _) = True
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index 9c70c3d..c070c36 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -10,6 +10,7 @@ import System.Posix.Signals
import System.Exit
import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn)
import System.IO.UTF8
+import Control.Monad.Reader.Class
import Control.Concurrent.Chan
import Codec.Binary.UTF8.String
import System.Directory
@@ -26,6 +27,7 @@ import Framework.Logger
import Framework.Types
import Framework.Urls
import Framework.Utils
+import Framework.Controller
import Framework.Http.Response
import Framework.Http.Middlewares
import Framework.Http.Httpd
@@ -39,7 +41,10 @@ sendfile filename = do
-- | Just serve static files
serveStatic :: StaticAction
-serveStatic ps rq s = serveStatic' ps rq s
+serveStatic rq s = do
+ ps <- ask
+ resp <- liftC $ serveStatic' ps rq s
+ return resp
serveStatic' ps rq resource =
if (rqMethod rq) == GET
diff --git a/Framework/Http/PostParser.hs b/Framework/Http/PostParser.hs
index f1f8f6a..07c6532 100644
--- a/Framework/Http/PostParser.hs
+++ b/Framework/Http/PostParser.hs
@@ -85,7 +85,7 @@ parseP part =
mimetype = v,
filebody = (init.init) oth }
else Multiple name $ parse b oth
- Nothing -> Single name $ Str $ (init.init) oth
+ Nothing -> Single name $ Str $ (init.init.init) oth
Left err -> error "Could not parse headers!"
cutAt :: String -> String -> (String, String)
diff --git a/Framework/Pager.hs b/Framework/Pager.hs
index cae8d49..ae5a297 100644
--- a/Framework/Pager.hs
+++ b/Framework/Pager.hs
@@ -4,6 +4,7 @@ module Framework.Pager
(pager
) where
+import Control.Monad.Reader.Class
import Database.HDBC (SqlValue (..), fromSql)
import Network.HTTP
@@ -13,36 +14,36 @@ import Framework.Models
import Framework.SQL
import Framework.API
import Framework.Types
+import Framework.Controller
import Framework.Http.Vars
-- | Represents pager HTML generator
type Pager = HttpRequest -> Int -> Int -> String
-- | Simple pager
-pager :: ActionConfig-> Int-> Query-> [SqlValue]-> Model-> IO ([Model], String)
+pager :: Int-> Query-> [SqlValue]-> Model-> Controller ActionConfig ([Model], String)
pager = genericPager genpager
-- | Generic pager function
genericPager :: Pager -- ^ Pager HTML generator function
- -> ActionConfig --
-> Int -- ^ Number of items per page
-> Query -- ^ DB query
-> [SqlValue] -- ^ DB query parameters
-> Model -- ^ Model of result
- -> IO ([Model], String) -- ^ Returns list of items on current page and HTML for pager
-genericPager pg conf perpage q params model = do
- countRes <- queryListSQL' conf (count q) params
+ -> Controller ActionConfig ([Model], String) -- ^ Returns list of items on current page and HTML for pager
+genericPager pg perpage q params model = do
+ countRes <- queryListSQL' (count q) params
+ rq <- asks request
let itemCount :: Int
itemCount = fromSql $ head (head countRes)
- rq = request conf
if itemCount < perpage
- then do items <- querySQL' conf q params model
+ then do items <- querySQL' q params model
return (items, "")
else do
let page = read $ httpGetVar' rq "page" "1"
let first = (page-1)*perpage
let pages = (itemCount `div` perpage)+1
- items <- querySQL' conf (q `limit` (first,perpage)) params model
+ items <- querySQL' (q `limit` (first,perpage)) params model
return (items, pg rq pages page)
-- | Simple pager HTML generator
@@ -51,7 +52,7 @@ genpager rq pages page = tagToHtml $ tag "p" ["class" := "pager"] (firstlink++pr
where
pagelist = [1..pages]
onepage n | n==page = tag "span" [] [Text $ show n]
- | otherwise = tag "a" ["href" := (pagelink n)] [Text $show n]
+ | otherwise = tag "a" ["href" := (pagelink n)] [Text $ show n]
pagelink m = httpAddGetVar rq "page" (show m)
prevlink | page==1 = []
| otherwise = [tag "a" ["href" := (pagelink $ page-1)] [Text "<"]]
diff --git a/Framework/Urls.hs b/Framework/Urls.hs
index 7cb37ec..f737f77 100644
--- a/Framework/Urls.hs
+++ b/Framework/Urls.hs
@@ -23,18 +23,19 @@ import Framework.Utils
import Framework.Types
import Framework.Wrapper
import Framework.Logger
+import Framework.Controller
import qualified Framework.Http.Sessions as Sessions
import Framework.Http.Response ((<+>))
type URLParts = [String]
-- | Function which get one String argument and (maybe) returns Response
-type StrAction = ActionConfig -> String -> Maybe (IO HttpResponse)
--- | Function which get one String argument and returns Response
-type StaticAction = StaticConfig -> HttpRequest -> String -> IO HttpResponse
+type StrAction = String -> HttpController
+-- | Function which get request and one String argument and returns Response
+type StaticAction = HttpRequest -> String -> StaticController
-- | Function which get many String arguments and (maybe) returns Response
-type ManyStrAction = ActionConfig -> URLParts -> Maybe (IO HttpResponse)
+type ManyStrAction = URLParts -> HttpController
-- | Function which just returns Response
-type HttpAction = ActionConfig -> IO HttpResponse
+type HttpAction = HttpController
-- | URL dispatcher config
data URLConf = Action HttpAction -- ^ Simple answer, not depending on URL
@@ -50,6 +51,7 @@ data URLConf = Action HttpAction -- ^ Simple answer
instance Show URLConf where
show (Action _) = "Some action"
show (OneOf x y) = (show x)++"\n| "++(show y)
+ show (RawFunction _) = "Some (raw) function"
show (Function _) = "Some function"
show (Prefix s u) = s++" --> "++(show u)
show (Regexp s u) = s++" --> "++(show u)
@@ -70,9 +72,13 @@ urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash)
urlJoin :: URLParts -> String
urlJoin us = concat $ intersperse "/" us
+return404 ps rq conf url = do
+ writeLog (errChan ps) rq $ "Not found: "++uriPath url
+ return $ noSuchUrl True conf
+
data URLResult = NoResult
- | AC (ActionConfig -> Maybe (IO HttpResponse))
- | SC (StaticConfig -> HttpRequest -> IO HttpResponse)
+ | AC HttpController
+ | SC (HttpRequest -> StaticController)
-- | Main dispatcher function
runURLConf :: StaticConfig -- ^ Static (global) config
@@ -89,18 +95,20 @@ runURLConf ps rq s conf =
NoResult -> return $ noSuchUrl True conf
AC fun -> do
(ac,addSession) <- mkActionConfig ps rq
- resp <- case fun ac of
- Nothing -> do
- writeLog (errChan ps) rq $ "Not found: "++uriPath url
- return $ noSuchUrl True conf
- Just act -> act
+ resp <- do
+ y <- evalController fun ac
+ case y of
+ Nothing -> return404 ps rq conf url
+ Just r -> return r
acFree ac
if addSession
then return $ resp <+> Sessions.sessionCookie (cookiesExp ac) (sessionID ac)
else return resp
SC fun -> do
- resp <- fun ps rq
- return resp
+ z <- evalController (fun rq) ps
+ case z of
+ Nothing -> return404 ps rq conf url
+ Just resp -> return resp
runURLConf' :: URLConf -> URLParts -> URLResult
-- runURLConf' _ [] _ = Nothing
@@ -114,21 +122,22 @@ runURLConf' (Regexp r conf) (x:xs) = let b = x =~ r :: Bo
runURLConf' (RegexpFun r f) (x:_) = let part = x =~ r :: String
in if null part
then NoResult
- else AC $ \ac -> f ac part
+ else AC $ f part
runURLConf' (ManyRegexpFun _ _ _) [] = NoResult
-runURLConf' (ManyRegexpFun u [] f) _ = AC $ \ac -> f ac (reverse u)
+runURLConf' (ManyRegexpFun u [] f) _ = AC $ f (reverse u)
runURLConf' (ManyRegexpFun u (r:rs) f) (x:xs) = let part = x =~ r :: String
in runURLConf' (ManyRegexpFun (part:u) rs f) xs
-runURLConf' (Action act) _ = AC $ \ac -> Just (act ac)
-runURLConf' (RawFunction f) x = SC $ \ps rq -> f ps rq (urlJoin x)
-runURLConf' (Function f) x = AC $ \ac -> f ac (urlJoin x)
+runURLConf' (Action act) _ = AC act
+runURLConf' (RawFunction f) x = SC $ \rq -> f rq (urlJoin x)
+runURLConf' (Function f) x = AC $ f (urlJoin x)
runURLConf' (OneOf c d) url = case runURLConf' c url of
NoResult -> runURLConf' d url
x -> x
-- runURLConf' (After c d) (x:xs) = case runURLConf' c [x] of
-- NoResult -> runURLConf' d xs
-- Just act -> Just (maybe act (act>>) (runURLConf' d xs ac))
-runURLConf' cc xs = error $ unlines ["URLConf error",show cc,show xs]
+-- runURLConf' cc xs = error $ unlines ["URLConf error",show cc,show xs]
+runURLConf' cc xs = NoResult
-- | If current part of URL is equal to given string, then call given function
(-->) :: String -> HttpAction -> URLConf
diff --git a/TODO b/TODO
index bc15a16..986776d 100644
--- a/TODO
+++ b/TODO
@@ -1,19 +1,21 @@
TODO
- * Протестировать поддержку PUT web-сервером;
- * [DONE] Перенести текущий правленный Network.Shed.Httpd в дерево проекта (написать свой?);
- * Лучше интегрировать Httpd в движок, в частности - чтоб средствами движка писал логи итп;
- * [DONE] Лучше формализовать формат запроса (reqMethod=="GET" -> reqMethod==GET итп), вероятно, следует привести в соответствие с Network.HTTP;
* Человеческая обработка завершения программы;
- * [DONE] При отдаче статики не коннектиться к БД и прочему;
- * Отдельная структура (и модуль?) для конфига (StaticConfig в нынешнем виде должна стать промежуточной структурой, заполняемой из конфига);
* Соответственно, все параметры, которые сейчас hard-coded, брать из конфига;
- * (?) Чтение конфига из файла либо удобный EDSL для конфига;
- * Более продвинутые и высокоуровневые функции генерации SQL;
- * (?) Слой абстракции от диалекта SQL;
- * (?) Генерация структуры Form по Model (с возможностью переопределить, или просто не использовать);
* Бэкенд для MySQL;
* Более высокоуровневый интерфейс для кэша - чтоб было легко закэшировать результат всей функции;
* Соответственно, простые средства для инвалидации кэша;
+ * Более продвинутые и высокоуровневые функции генерации SQL;
+ * (?) Чтение конфига из файла либо удобный EDSL для конфига;
+ * (?) Слой абстракции от диалекта SQL;
+ * (?) Генерация структуры Form по Model (с возможностью переопределить, или просто не использовать);
* (?) Автоматические CRUD-контроллеры;
+ * (?) Генерация описаний моделей по БД;
* (!) Документация ко всей этой красоте.
+ * Протестировать поддержку PUT web-сервером;
+
+ * [DONE] Перенести текущий правленный Network.Shed.Httpd в дерево проекта (написать свой?);
+ * [DONE] Лучше интегрировать Httpd в движок, в частности - чтоб средствами движка писал логи итп;
+ * [DONE] Лучше формализовать формат запроса (reqMethod=="GET" -> reqMethod==GET итп), вероятно, следует привести в соответствие с Network.HTTP;
+ * [DONE] При отдаче статики не коннектиться к БД и прочему;
+ * [DONE] Отдельная структура (и модуль?) для конфига (StaticConfig в нынешнем виде должна стать промежуточной структурой, заполняемой из конфига);