diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 1320505..9a1c581 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -59,8 +59,6 @@ allposts = do ("comments", C lastComments), ("message", C message), ("pager", C pagerHtml)] --- liftC $ print $ length html --- liftC $ print $ length $ encodeString html cachePut key html return $ ok html @@ -100,22 +98,13 @@ editpost sid = do case rqMethod rq of GET -> do post <- getOneObject postModel pid --- let ptitle = post -:> "title" --- let pbody = post -:> "body" --- (form,err) <- retryEditForm postForm "1" [("title",fromSql ptitle), ("body",fromSql pbody)] [] url (form,err) <- editModelForm post postForm "1" url return $ renderToResponse "editpost.html" [("form", C form), ("invalid", C err)] - POST -> do - let (d,_) = getForm allForms rq "postform" - case d of - Right post -> let ptitle = post -:> "title" - pbody = post -:> "body" - in do queryListSQL (updateM postModel ("id":==:sid)) [ptitle, pbody] - commit - invalidatePostsCache - return $ redirectG "/blog/" ["code" := "3"] - Left e -> returnInvalidForm postForm "1" e + POST -> + do updateModel allForms postModel postForm "1" sid + invalidatePostsCache + return $ redirectG "/blog/" ["code" := "3"] onepost :: StrAction onepost sid = do diff --git a/Framework/API.hs b/Framework/API.hs index 151367f..4721283 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -2,157 +2,26 @@ -- | Contains `userland` API. Wraps functions from many other modules. -- API functions get ActionConfig parameter, which contains all data about current job. module Framework.API - (ActionConfig (..), - cacheGet, cachePut, cacheUnset, - tryReturnFromCache, - serveHttp, serveStatic, - sessionLookup, sessionSet, - queryList, queryList', query, query', - commit, - queryListSQL, queryListSQL', querySQL, querySQL', - getOneObject, - getcookie, setcookie, - accessLog, errorLog + (getcookie, setcookie, + serveStatic, serveHttp, + module Framework.API.Cache, + module Framework.API.Sessions, + module Framework.API.Storage, + module Framework.API.SQL, + module Framework.API.Logger, ) where -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 Framework.Models -import qualified Framework.Utils as Utils import qualified Framework.Http.Cookies as Cookies -import qualified Framework.Http.Sessions as Sessions -import qualified Framework.Storage as Storage -import qualified Framework.Urls as Urls -import qualified Framework.Cache as Cache -import qualified Framework.SQL as SQL -import qualified Framework.Logger as Logger -import Framework.Models (Model) -import Framework.Http.Response ((<+>),ok) -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 $ {-do - print $ length value -} - Cache.cPut cb key value - -cacheUnset :: String -> Controller ActionConfig Bool -cacheUnset key = do - cb <- asks cacheBackend - liftC $ Cache.cUnset cb key - -tryReturnFromCache :: String -> Controller ActionConfig () -tryReturnFromCache key = do - c <- cacheGet key - case c of - Just content -> {-do liftC $ print $ length content-} - returnNow $ ok content - Nothing -> return () - ----------------------------------------------------------------------------------------------------------- --- * Sessions API - --- | Get variable from session -sessionLookup :: String -> Controller ActionConfig String -sessionLookup name = do - mm <- asks sessionMap - return $ maybe "" id $ M.lookup name mm - --- | Set variable into session -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 :: String -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] -queryList sql params = do - conn <- asks dbconnection - liftC $ Storage.query conn sql params +import Framework.Http.HTTPServer (serveStatic, serveHttp) --- | Just as "queryList", but strict. -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 :: 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 - --- | Same as "query", but strict. -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 :: 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 :: 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' :: 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 :: 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' :: 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 - -getOneObject :: Model -> Int -> Controller ActionConfig Model -getOneObject model oid = do - case getPK model of - Just name -> do - objs <- querySQL' ((SQL.table model) `SQL.restrict` (name SQL.:==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model - assertC $ (length objs)==1 - return $ head objs - Nothing -> internalError "Could not find primary key!" +import Framework.API.Cache +import Framework.API.Sessions +import Framework.API.Storage +import Framework.API.SQL +import Framework.API.Logger ---------------------------------------------------------------------------------------------------------- -- * Cookies API @@ -166,22 +35,3 @@ getcookie ac name = Cookies.getcookie (request ac) name setcookie :: ActionConfig -> String -> String -> Header setcookie ac name value = Cookies.setcookie (cookiesExp ac) name value ----------------------------------------------------------------------------------------------------------- --- * Logger API - --- | Write a message to access log -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 :: 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/API/Cache.hs b/Framework/API/Cache.hs new file mode 100644 index 0000000..c129b82 --- /dev/null +++ b/Framework/API/Cache.hs @@ -0,0 +1,38 @@ +module Framework.API.Cache where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import Framework.Cache +import Framework.Http.Response + +---------------------------------------------------------------------------------------------------------- +-- * Cache API + +cacheGet :: String -> Controller ActionConfig (Maybe String) +cacheGet key = do + cb <- asks cacheBackend + liftC $ cGet cb key + +cachePut :: String -> String -> Controller ActionConfig Bool +cachePut key value = do + cb <- asks cacheBackend + liftC $ {-do + print $ length value -} + cPut cb key value + +cacheUnset :: String -> Controller ActionConfig Bool +cacheUnset key = do + cb <- asks cacheBackend + liftC $ cUnset cb key + +tryReturnFromCache :: String -> Controller ActionConfig () +tryReturnFromCache key = do + c <- cacheGet key + case c of + Just content -> {-do liftC $ print $ length content-} + returnNow $ ok content + Nothing -> return () + + diff --git a/Framework/API/Logger.hs b/Framework/API/Logger.hs new file mode 100644 index 0000000..648b153 --- /dev/null +++ b/Framework/API/Logger.hs @@ -0,0 +1,27 @@ +module Framework.API.Logger where + +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Controller +import qualified Framework.Logger as Logger + +---------------------------------------------------------------------------------------------------------- +-- * Logger API + +-- | Write a message to access log +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 :: 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/API/SQL.hs b/Framework/API/SQL.hs new file mode 100644 index 0000000..a0e268e --- /dev/null +++ b/Framework/API/SQL.hs @@ -0,0 +1,71 @@ +module Framework.API.SQL where + +import Control.Monad.Reader.Class +import qualified Database.HDBC as HDBC +import qualified Data.Map as M + +import Framework.Types +import Framework.Controller +import qualified Framework.Storage as Storage +import Framework.SQL +import Framework.Models +import Framework.Forms.Types +import Framework.Forms.Validation + +import Framework.API.Storage + +---------------------------------------------------------------------------------------------------------- +-- * Storage/SQL API + +-- | Same as "queryList", but gets Query instead of plain SQL +queryListSQL :: Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryListSQL q params = do + conn <- asks dbconnection + liftC $ Storage.query conn (sql q) params + +-- | Same, but strict. +queryListSQL' :: Query -> [HDBC.SqlValue] -> Controller ActionConfig [[HDBC.SqlValue]] +queryListSQL' q params = do + conn <- asks dbconnection + liftC $ Storage.query' conn (sql q) params + +-- | Same as "query", but gets Query object instead of plain SQL +querySQL :: Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model] +querySQL q params model = do + conn <- asks dbconnection + liftC $ Storage.queryR conn (sql q) params model + +-- | Same, but strict. +querySQL' :: Query -> [HDBC.SqlValue] -> Model -> Controller ActionConfig [Model] +querySQL' q params model = do + conn <- asks dbconnection + liftC $ Storage.queryR' conn (sql q) params model + +-- | Get an object from DB specified by Model and object ID. +-- Fail if count(such objects)=!1. +getOneObject :: Model -> Int -> Controller ActionConfig Model +getOneObject model oid = do + idf <- forceMaybe "Could not find primary key!" $ getPK model + objs <- querySQL' ((table model) `restrict` (idf :==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model + assertC $ (length objs)==1 + return $ head objs + +updateModel :: M.Map String Form -- ^ Map of all forms + -> Model -- ^ Model + -> Form + -> String -- ^ Form ID + -> String -- ^ Object ID + -> Controller ActionConfig () +updateModel mm model form fid oid = do + rq <- asks request + idf <- forceMaybe "Could not find PK!" $ getPK model + let (d,_) = getForm mm rq (formName form) + case d of + Right obj -> do queryListSQL (updateM model (idf :==: oid)) values + commit + where + fields = map fieldName $ filter (not . isExternalField) $ mFields model + values = map (obj -:>) fields + Left e -> returnInvalidForm form fid e + + diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs new file mode 100644 index 0000000..1074cb8 --- /dev/null +++ b/Framework/API/Sessions.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes, NamedFieldPuns #-} +module Framework.API.Sessions where + +import Control.Monad.Reader.Class +import qualified Data.Map as M + +import Framework.Types +import Framework.Controller +import Framework.Http.Sessions + +---------------------------------------------------------------------------------------------------------- +-- * Sessions API + +-- | Get variable from session +sessionLookup :: String -> Controller ActionConfig String +sessionLookup name = do + mm <- asks sessionMap + return $ maybe "" id $ M.lookup name mm + +-- | Set variable into session +sessionSet :: String -> String -> Controller ActionConfig () +sessionSet name value = do + ActionConfig {sessionsBackend,sessionID,sessionMap} <- ask + liftC $ sPush sessionsBackend sessionID $ M.insert name value sessionMap diff --git a/Framework/API/Storage.hs b/Framework/API/Storage.hs new file mode 100644 index 0000000..c065f90 --- /dev/null +++ b/Framework/API/Storage.hs @@ -0,0 +1,49 @@ +module Framework.API.Storage where + +import Control.Monad.Reader.Class +import qualified Database.HDBC as HDBC + +import Framework.Types +import Framework.Controller +import Framework.Models +import qualified Framework.Storage as Storage + +---------------------------------------------------------------------------------------------------------- +-- * Storage API + +-- | Simple DB query. Lazy. +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' :: 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 :: 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 + +-- | Same as "query", but strict. +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 :: Controller ActionConfig () +commit = do + conn <- asks dbconnection + liftC $ Storage.commit conn + + diff --git a/Framework/Controller.hs b/Framework/Controller.hs index 9eb03c1..2503a88 100644 --- a/Framework/Controller.hs +++ b/Framework/Controller.hs @@ -53,6 +53,18 @@ returnNow v = Controller $ \_ -> return (RightNow v) internalError :: String -> Controller s a internalError msg = returnNow $ response 500 [] msg +errorIf :: String -> Bool -> Controller s () +errorIf msg b = + if b + then internalError msg + else return () + +forceMaybe :: String -> Maybe a -> Controller s a +forceMaybe msg x = + case x of + Just v -> return v + Nothing -> internalError msg + rejectUrl :: Controller s a rejectUrl = Controller $ \_ -> return RejectUrl diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index ea4fee5..047301f 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -23,7 +23,7 @@ import Framework.Types import Framework.Utils import Framework.Controller import Framework.Urls (myUrl) -import Framework.API +import Framework.API.Sessions import Framework.Models import Framework.Http.Response (redirectG) import Framework.Http.Vars @@ -98,6 +98,8 @@ retryEditForm form fid defvals hidden action = do then return (formToHtml $ refillFormU [] form fid hidden defvals action, "") else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err) +-- FIXME: should this be moved to API.hs ? +-- | Show edit form for model editModelForm :: Model -> Form -> String -- ^ Form ID @@ -110,13 +112,13 @@ editModelForm model form fid action = retryEditForm form fid (zip fields values) returnInvalidForm :: Form -> String -- ^ Form ID -> [String] -- ^ List of erroneus filled fields - -> HttpController + -> Controller ActionConfig a 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)] + returnNow $ redirectG (myUrl rq) ["invalid" := (unwords errs)] isRight :: Either t1 t -> Bool isRight (Right _) = True