diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index d4c728f..1320505 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -5,6 +5,7 @@ import qualified Data.Map as M
import Control.Monad
import Control.Monad.Reader.Class
import Network.HTTP
+import Codec.Binary.UTF8.String
import Framework.Types
import Framework.Controller
@@ -58,6 +59,8 @@ 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
@@ -96,12 +99,11 @@ editpost sid = do
pid = read sid
case rqMethod rq of
GET ->
- do posts <- querySQL' ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel
- assertC $ (length posts)==1
- let post = head posts
- let ptitle = post -:> "title"
- let pbody = post -:> "body"
- (form,err) <- retryEditForm postForm "1" [("title",fromSql ptitle), ("body",fromSql pbody)] [] url
+ 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
@@ -123,12 +125,11 @@ onepost sid = do
(form,err) <- retryForm commentForm "1" [] url
case rqMethod rq of
GET -> do
- 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
+ post <- getOneObject postModel pid
+ comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?") `order` (Asceding "dt")) [SqlInt32 $ fromIntegral pid] commentModel
let code = httpGetVar' rq "code" ""
let message = maybe "" id $ lookup code messagecodes
- return $ renderToResponse "onepost.html" [("post", C (head post)),
+ return $ renderToResponse "onepost.html" [("post", C post),
("comments", C comments),
("message", C message),
("form", C form)]
@@ -139,7 +140,7 @@ onepost sid = do
do liftC $ print $ mFields comment
let cAuthor = comment -:> "author"
let cBody = comment -:> "body"
- queryListSQL (insertM commentModel) [SqlInt32 pid, cAuthor, cBody]
+ queryListSQL (insertM commentModel) [SqlInt32 $ fromIntegral pid, cAuthor, cBody]
commit
return $ redirectG url ["code" := "2"]
Left e -> returnInvalidForm commentForm "1" e
diff --git a/Blog/Models.hs b/Blog/Models.hs
index 9bee8c5..c3e159b 100644
--- a/Blog/Models.hs
+++ b/Blog/Models.hs
@@ -18,7 +18,7 @@ import Framework.Markdown
postModel = Model {
mName = "post",
mTable = "posts",
- mFields = ["id" ::: IntegerColumn,
+ mFields = ["id" ::: PrimaryKey,
"dt" ::: CurrentDateColumn,
"title" ::: StringColumn,
"body" ::: StringColumn],
@@ -50,7 +50,7 @@ addNComments post n = setCached postModel "ncomments" IntegerColumn n
commentModel = Model {
mName = "comment",
mTable = "comments",
- mFields = ["id" ::: IntegerColumn,
+ mFields = ["id" ::: PrimaryKey,
"pid" ::: ForeignKey postModel "id",
"dt" ::: CurrentDateColumn,
"author" ::: StringColumn,
@@ -68,7 +68,7 @@ commentForm = Form {
formName = "comment",
formModel = commentModel,
fFields = [ Field "author" "" inputbox noValidate,
- Field "comment" "" textarea (notEmpty "comment")]
+ Field "body" "" textarea (notEmpty "body")]
}
-------------------------------------------------------------------------------
diff --git a/Framework/API.hs b/Framework/API.hs
index eaa4e3a..151367f 100644
--- a/Framework/API.hs
+++ b/Framework/API.hs
@@ -10,6 +10,7 @@ module Framework.API
queryList, queryList', query, query',
commit,
queryListSQL, queryListSQL', querySQL, querySQL',
+ getOneObject,
getcookie, setcookie,
accessLog, errorLog
) where
@@ -23,6 +24,7 @@ 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
@@ -46,7 +48,9 @@ cacheGet key = do
cachePut :: String -> String -> Controller ActionConfig Bool
cachePut key value = do
cb <- asks cacheBackend
- liftC $ Cache.cPut cb key value
+ liftC $ {-do
+ print $ length value -}
+ Cache.cPut cb key value
cacheUnset :: String -> Controller ActionConfig Bool
cacheUnset key = do
@@ -57,7 +61,8 @@ tryReturnFromCache :: String -> Controller ActionConfig ()
tryReturnFromCache key = do
c <- cacheGet key
case c of
- Just content -> returnNow $ ok content
+ Just content -> {-do liftC $ print $ length content-}
+ returnNow $ ok content
Nothing -> return ()
----------------------------------------------------------------------------------------------------------
@@ -140,6 +145,15 @@ 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!"
+
----------------------------------------------------------------------------------------------------------
-- * Cookies API
-- FIXME: should this functions be monadic?
diff --git a/Framework/Controller.hs b/Framework/Controller.hs
index 95a2f07..9eb03c1 100644
--- a/Framework/Controller.hs
+++ b/Framework/Controller.hs
@@ -4,6 +4,7 @@ module Framework.Controller where
import Control.Monad.Reader.Class
import Framework.Types
+import Framework.Http.Response
data ControllerResult a = RejectUrl
| RightNow HttpResponse
@@ -46,9 +47,12 @@ assertC b =
then return ()
else rejectUrl
-returnNow :: HttpResponse -> Controller s ()
+returnNow :: HttpResponse -> Controller s a
returnNow v = Controller $ \_ -> return (RightNow v)
+internalError :: String -> Controller s a
+internalError msg = returnNow $ response 500 [] msg
+
rejectUrl :: Controller s a
rejectUrl = Controller $ \_ -> return RejectUrl
diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs
index 069887f..ea4fee5 100644
--- a/Framework/Forms/Validation.hs
+++ b/Framework/Forms/Validation.hs
@@ -2,6 +2,7 @@
module Framework.Forms.Validation
(refillForm,
retryForm, retryEditForm,
+ editModelForm,
returnInvalidForm,
formVars, formVarsNames, formVarsValues,
notEmpty, noValidate,
@@ -97,6 +98,15 @@ 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)
+editModelForm :: Model
+ -> Form
+ -> String -- ^ Form ID
+ -> String -- ^ Target URL
+ -> Controller ActionConfig (String, String)
+editModelForm model form fid action = retryEditForm form fid (zip fields values) [] action
+ where fields = map fieldName $ filter (not . isExternalField) $ mFields model
+ values = map (D.fromSql.(model -:>)) fields
+
returnInvalidForm :: Form
-> String -- ^ Form ID
-> [String] -- ^ List of erroneus filled fields
diff --git a/Framework/Http/Httpd.hs b/Framework/Http/Httpd.hs
index 73c8b82..9c26d03 100644
--- a/Framework/Http/Httpd.hs
+++ b/Framework/Http/Httpd.hs
@@ -38,6 +38,7 @@ import Network.HTTP
import Network.Stream
import System.IO hiding (hPutStr,hPutStrLn,print,hGetLine)
import System.IO.UTF8
+import Codec.Binary.UTF8.String
import Control.Monad
import Control.Monad
import Control.Concurrent
@@ -67,7 +68,7 @@ initServer
-> IO Server -- ^ A token for the Server
initServer =
initServerMain
- (\body -> ([mkHeader HdrContentLength (show $ length body)], body))
+ (\body -> ([mkHeader HdrContentLength (show $ length $ encodeString body)], body))
{- |
This server transfers documents in chunked mode
diff --git a/Framework/Http/Response.hs b/Framework/Http/Response.hs
index d52e30b..c829483 100644
--- a/Framework/Http/Response.hs
+++ b/Framework/Http/Response.hs
@@ -4,6 +4,7 @@ module Framework.Http.Response
redirect, redirectG, redirectP,
(<+>), (<++>) ) where
+import System.IO.UTF8
import Network.HTTP
import Framework.Types
diff --git a/Framework/Models.hs b/Framework/Models.hs
index 03d4184..3086872 100644
--- a/Framework/Models.hs
+++ b/Framework/Models.hs
@@ -5,6 +5,7 @@ module Framework.Models
Model (..),
ModelField (..),
(-:>),
+ getPK, isExternalField,
foreignModel, foreignField,
updateField, setCached,
record, record',
@@ -19,6 +20,7 @@ import Framework.Types
-- | Type of DB table column
data ColumnType = IntegerColumn
+ | PrimaryKey
| ForeignKey Model String
| StringColumn
| BoolColumn
@@ -27,6 +29,7 @@ data ColumnType = IntegerColumn
-- | Default value of column type
defaultValue :: ColumnType -> SqlValue
+defaultValue PrimaryKey = SqlInt32 0
defaultValue IntegerColumn = SqlInt32 0
defaultValue (ForeignKey _ _) = SqlInt32 0
defaultValue StringColumn = SqlString ""
@@ -42,6 +45,13 @@ data Model = Model {
}
deriving (Eq,Show)
+getPK :: Model -> Maybe String
+getPK model = getPK' $ mFields model
+ where
+ getPK' [] = Nothing
+ getPK' (x:xs) | fieldType x == PrimaryKey = Just $ fieldName x
+ | otherwise = getPK' xs
+
-- | Connected model for foreign key
foreignModel :: ColumnType -> Model
foreignModel (ForeignKey m _) = m
@@ -50,6 +60,12 @@ foreignModel (ForeignKey m _) = m
foreignField :: ColumnType -> String
foreignField (ForeignKey _ f) = f
+isExternalField f = case fieldType f of
+ PrimaryKey -> True
+ CurrentDateColumn -> True
+ ForeignKey _ _ -> True
+ _ -> False
+
-- | Field for Model
data ModelField = String ::: ColumnType
| FilledField String ColumnType SqlValue
@@ -60,7 +76,7 @@ data ModelField = String ::: ColumnType
model -:> fieldname = lookupField ((mFields model)++(mCached model)) fieldname
lookupField :: [ModelField] -> String -> SqlValue
-lookupField [] _ = error "field name not found by lookupField!"
+lookupField [] name = error $ "field name "++name++" not found by lookupField!"
lookupField (f:fs) name | (fieldName f)==name = fieldValue f
| otherwise = lookupField fs name
@@ -84,8 +100,8 @@ record m lst = m { mFields = filledFields }
filledFields = combine (mFields m) lst
combine _ [] = []
combine [] _ = []
- combine flds@((name:::tp):fs) vals@(x:xs) =
- if ("id" `isSuffixOf` name) || (tp==CurrentDateColumn)
+ combine flds@(f@(name:::tp):fs) vals@(x:xs) =
+ if isExternalField f
then (FilledField name tp (defaultValue tp)):(combine fs vals)
else (FilledField name tp x):(combine fs xs)
@@ -126,6 +142,6 @@ nthTypeField tps x n = (filter (isTypeOf tps) ((mFields x)++(mCached x)))!!(n-1)
instance TemplateOne Model where
showO = show
- intField n x = fieldValue' $ nthTypeField [IntegerColumn] x n
+ intField n x = fieldValue' $ nthTypeField [IntegerColumn,PrimaryKey] x n
stringField n x = fieldValue' $ nthTypeField [StringColumn,CurrentDateColumn] x n
boolField n x = fieldValue' $ nthTypeField [BoolColumn] x n
diff --git a/Framework/SQL.hs b/Framework/SQL.hs
index a05037f..7ce3bf7 100644
--- a/Framework/SQL.hs
+++ b/Framework/SQL.hs
@@ -16,6 +16,8 @@ module Framework.SQL
aggregate, count
) where
+import Debug.Trace
+
import Data.List
import Database.HDBC
import qualified Data.Convertible.Base as CD
@@ -102,6 +104,9 @@ instance SQLFragment SQLOrder where
sqlFragment (Asceding o) = o++" ASC"
sqlFragment (Desceding o) = o++" DESC"
+-- sql q = let s = sql' q
+-- in trace s s
+
-- | Generate SQL query from its Query description
sql :: Query -> String
sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" FROM "++tlist++other