diff --git a/Blog/Blog b/Blog/Blog index bd9931a..985960b 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index e3219ab..a7c17c1 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -1,7 +1,7 @@ import System.IO import Network.Shed.Httpd -import Database.HDBC (SqlValue(..)) +import Database.HDBC (SqlValue(..),fromSql) import Framework.Types import Framework.API @@ -18,10 +18,12 @@ import Config import Models messagecodes = [("1","Пост успешно добавлен."), - ("2","Комментарий добавлен.")] + ("2","Комментарий добавлен."), + ("3","Пост отредактирован.")] urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost + <|> "blog" // "edit" // number ~> editpost <|> "blog" --> allposts allposts :: HttpAction @@ -36,7 +38,7 @@ allposts hp rq = withConfig hp rq $ \conf -> do newpost :: HttpAction newpost hp rq = withConfig hp rq $ \conf -> do - (form,err) <- retryForm conf postForm "1" url + (form,err) <- retryForm conf postForm "1" [] url case reqMethod rq of "GET" -> return $ renderToResponse "newpost.html" [("form", C form), ("invalid", C err)] @@ -53,9 +55,35 @@ newpost hp rq = withConfig hp rq $ \conf -> do Left e -> returnInvalidForm conf postForm "1" e where url = myUrl rq +editpost :: StrAction +editpost hp rq sid = Just $ withConfig hp rq $ \conf -> do + case reqMethod rq of + "GET" -> + do posts <- querySQL' conf ((table "posts") `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 + 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 conf + (updateQ ((table "posts") `onlyFields` ["dt","title","body"]) ("id" :==: sid) ["current_timestamp","?","?"]) + [ptitle, pbody] + commit conf + return $ redirectG "/blog/" ["code" =: "3"] + Left e -> do cont <- returnInvalidForm conf postForm "1" e + return cont + where url = myUrl rq + pid = read sid + onepost :: StrAction onepost hp rq sid = Just $ withConfig hp rq $ \conf -> do - (form,err) <- retryForm conf commentForm "1" url + (form,err) <- retryForm conf commentForm "1" [] url case reqMethod rq of "GET" -> do post <- querySQL' conf ((table "posts") `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel diff --git a/Blog/Models.hs b/Blog/Models.hs index 41cfe1e..c595d15 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -29,7 +29,7 @@ postForm = Form { formName = "postform", formModel = postModel, fFields = [ Field "title" "" inputbox noValidate, - Field "post" "" textarea (notEmpty "post")] + Field "body" "" textarea (notEmpty "body")] } addNComments post n = setCached postModel "ncomments" IntegerColumn n diff --git a/Blog/blog.db b/Blog/blog.db index 2442823..462ccc7 100644 Binary files a/Blog/blog.db and b/Blog/blog.db differ diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html index 2942262..f455522 100644 --- a/Blog/templates/blogposts.html +++ b/Blog/templates/blogposts.html @@ -14,6 +14,7 @@ <h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2> <p><small>at {{postDate post}}</small></p> <p>{{postbody post}}</p> + <p><small><a href="/blog/edit/{{postid post}}">Edit</a></small></p> <hr> {%endfor%} diff --git a/Blog/templates/editpost.html b/Blog/templates/editpost.html new file mode 100644 index 0000000..886ee1f --- /dev/null +++ b/Blog/templates/editpost.html @@ -0,0 +1,16 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>Edit blog post</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>Edit post</h1> + {%if invalid%} + <p>Пост не может быть пустым.</p> + {%endif%} + + {{form}} + + </body> +</html> diff --git a/Framework/API.hs b/Framework/API.hs index 840ed9d..ca73c6d 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -37,7 +37,7 @@ sessionLookup (ActionConfig {sessionMap}) name = return $ maybe "" id $ M.lookup sessionSet :: ActionConfig -> String -> String -> IO () sessionSet (ActionConfig {sessionsBackend,sessionID,sessionMap}) name value = - Sessions.sPush sessionsBackend sessionID (trace ("Setting "++name++"="++value) mm) + Sessions.sPush sessionsBackend sessionID mm where mm = M.insert name value sessionMap ---------------------------------------------------------------------------------------------------------- diff --git a/Framework/Forms.hs b/Framework/Forms.hs index a5f49e5..31c4038 100644 --- a/Framework/Forms.hs +++ b/Framework/Forms.hs @@ -4,8 +4,9 @@ module Framework.Forms Inputbox, Textarea, inputbox, textarea, tag, - createform, editform, - retryForm, returnInvalidForm, + createform, refillForm, + retryForm, retryEditForm, + returnInvalidForm, Form (..), FormField (..), formVars, formVarsNames, formVarsValues, @@ -44,14 +45,23 @@ class Widget w where -- | Read widget's value from string. Not used yet. wRead :: String -> WContent w +hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] "" + +mangleName formname fid name = formname++fid++"-"++name + -- | Generate <form> tag -makeform :: (HttpValue a) => String -> String -> a -> String -> String -makeform name fid action content = tag "form" ["method" =: "POST","action" =: action] (fidfield++namefield++content) - where fidfield = tag "input" ["name" =: "formid", "type" =: "hidden", "value" =: fid] "" - namefield = tag "input" ["name" =: "formname", "type" =: "hidden", "value" =: name] "" +formTag :: (HttpValue a) => String -> String -> a -> String -> String +formTag name fid action content = tag "form" ["method" =: "POST","action" =: action] (fidfield++namefield++content) + where fidfield = hiddenField "formid" fid + namefield = hiddenField "formname" name -- | Generate form row (widget with label) -formrow :: (HttpValue [a]) => String -> String -> String -> [a] -> FormField -> String +formrow :: String -- ^ Form name + -> String -- ^ Form ID + -> String -- ^ Default value for widget + -> String -- ^ `class` attribute for <tr> + -> FormField -- ^ Field + -> String formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "td" [] itemlabel)++(tag "td" [] (html widget itemname def)) where attrs = if null cls then [] @@ -59,47 +69,75 @@ formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "t itemlabel = if null label then (capitalize name)++":" else label - itemname = fname++fid++"-"++name + itemname = mangleName fname fid name submit :: String submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" --- | Generate an empty form -createform :: (HttpValue a) => Form -- ^ A form to generate - -> String -- ^ Form ID - -> a -- ^ Form target url - -> String -createform form fid action = makeform name fid action content - where content = tag' "table" [] (concat $ map (formrow name fid "" "") (fFields form))++submit - name = formName form - --- | Generate a \"to-edit\" form -editform :: (HttpValue a) => [String] -- ^ List of erroneus filled fields names - -> Form -- ^ A form to generate - -> String -- ^ Form ID - -> [(String,String)] -- ^ (name,value) pairs - -> a -- ^ Form's target url - -> String -editform errfields form fid pairs action = makeform name fid action content - where content = tag' "table" [] (concat $ zipWith3 (formrow name fid) vals clss (fFields form))++submit - vals = map (\n -> maybe "" id $ lookup (name++fid++"-"++n) pairs) names +createform :: Form + -> String + -> [(String,String)] + -> String + -> String +createform form fid pairs action = formTag name fid action content + where name = formName form + content = tag "table" [] (concat $ map (formrow name fid "" "") (fFields form))++hiddenFields++submit + hiddenFields = concat $ map ((uncurry hiddenField).mangle) pairs + mangle (n,v) = (mangleName name fid n, v) + +-- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and +-- fill with previous values +refillFormG :: (String -> String -> String -> String) -- ^ Mangle function + -> [String] -- ^ List of erroneus filled fields names + -> Form -- ^ A form to generate + -> String -- ^ Form ID + -> [(String,String)] -- ^ Hidden values + -> [(String,String)] -- ^ (name,value) pairs (already filled) + -> String -- ^ Form's target url + -> String +refillFormG mfun errfields form fid hidden pairs action = formTag name fid action content + where content = tag' "table" [] (concat $ zipWith3 (formrow name fid) vals clss (fFields form))++hiddenFields++submit + vals = map (\n -> maybe "" id $ lookup (mfun name fid n) pairs) names names = map fName (fFields form) clss = map (\n -> if n `elem` errfields then "error" else "") names name = formName form + hiddenFields = concat $ map ((uncurry hiddenField).mangle) hidden + mangle (n,v) = (mfun name fid n, v) + +refillForm = refillFormG mangleName +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 action = do +retryForm conf form fid pairs action = do filled <- sessionLookup conf "filled" +-- putStrLn $ "retryForm: Session read: "++(show filled) let defvals = decodePairs filled +-- putStrLn $ "retryForm: defvals: "++(show defvals) + let err = httpGetVar' (request conf) "invalid" "" + if null err + then return (createform form fid pairs action, "") + else return (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" + let filledVals = decodePairs filled let err = httpGetVar' (request conf) "invalid" "" if null err - then return (createform form fid action, "") - else return (editform (words err) form fid defvals action, err) + then return (refillFormU [] form fid hidden defvals action, "") + else return (refillForm (words err) form fid hidden filledVals action, err) returnInvalidForm :: ActionConfig -> Form -> String -> [String] -> IO Response returnInvalidForm conf form fid errs = @@ -192,7 +230,7 @@ formVarsValues :: Form -> String -> Request -> [String] formVarsValues form fid rq = map (\name -> httpPostVar' rq name "") (formVarsNames form fid) formVarsNames :: Form -> String -> [String] -formVarsNames form fid = map ((formName form)++) $ map (fid++) $ map ("-"++) $ map fName $ fFields form +formVarsNames form fid = map (mangleName (formName form) fid) $ map fName $ fFields form formVars :: Form -> String -> Request -> [(String,String)] formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) diff --git a/Framework/SQL.hs b/Framework/SQL.hs index 0c74683..b0fb257 100644 --- a/Framework/SQL.hs +++ b/Framework/SQL.hs @@ -10,6 +10,7 @@ module Framework.SQL restrict, limit, insertQ, + updateQ, aggregate, count ) where @@ -28,6 +29,11 @@ data Query = Query { iTable :: String, iFields :: [String], iValues :: [String] } + | UpdateQuery { + uTable :: String, + uFields :: [String], + uValues :: [String], + uWhere :: SQLCondition } deriving (Eq,Show) data SQLField = QField String @@ -103,6 +109,9 @@ sql (Query fields tables whre order group ls) = "SELECT "++(sqlList fields)++" F lpart | Just (x,y) <- ls = " LIMIT "++(show x)++", "++(show y) | otherwise = "" sql (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fields)++") VALUES ("++(commas values)++")" +sql (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart + where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre) + eqs = commas $ zipWith (\n v -> n++"="++v) fields values commas = concat . intersperse ", " sqlList = commas.map sqlFragment @@ -137,6 +146,8 @@ limit q pair = q {qLimits = Just pair} insertQ (Query fields tables _ _ _ _) values = InsertQuery (tablename $ head tables) (map fieldname fields) values +updateQ (Query fields tables _ _ _ _) cond values = UpdateQuery (tablename $ head tables) (map fieldname fields) values cond + -- myquery = (table "users") `select` ["name","passwd"] `order` (Asceding "name") -- main = print $ sql myquery diff --git a/Framework/Sessions.hs b/Framework/Sessions.hs index 15d6ff5..51fa907 100644 --- a/Framework/Sessions.hs +++ b/Framework/Sessions.hs @@ -53,6 +53,7 @@ instance SessionBackend FilesBackend where -- putStrLn "File should be closed" let ls = lines s let pairs = map spliteq ls +-- putStrLn $ "Session read: "++(show pairs) return $ M.fromList pairs else return M.empty where file = path </> sid diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 2c2f666..83f827b 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -1,6 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} module Framework.Urls where +import Debug.Trace + +import Data.Char import Codec.Binary.UTF8.String import Text.Regex.PCRE import Network.URI @@ -111,15 +114,18 @@ httpAddGetVar rq name value = urlencode (map packHeader pairs') where pairs' = update name value pairs pairs = decodePairs (uriQuery $ reqURI rq) -decodePairs s = map (both decodeString) $ queryToArguments $ replaceplus s - where both f (x,y) = (f x, f y) +decodePairs s = map (both tryDecode) (trace (show pairs) pairs) + where pairs = queryToArguments $ replaceplus s + both f (x,y) = (f x, f y) + tryDecode s | isUTF8Encoded s = decodeString s + | otherwise = s decodePair = head.decodePairs urlencode pairs = '?':(concat $ intersperse "&" $ map escapePair pairs) escapePair (n:=v) = (esc n)++"="++(esc $ httpShow v) -esc = escapeURIString isAllowedInURI +esc = (escapeURIString isAllowedInURI).encodeString myUrl :: Request -> String myUrl rq = uriPath $ reqURI rq