diff --git a/Blog/Blog b/Blog/Blog index dc91d96..1d0aae2 100755 Binary files a/Blog/Blog and b/Blog/Blog differ diff --git a/Blog/Blog.hs b/Blog/Blog.hs index dd88eeb..8756bc9 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -7,6 +7,7 @@ import Framework.Types import Framework.API import Framework.SQL import Framework.HTTPServer +import Framework.Response import Framework.TEngine.TemplateUtil import Framework.Urls import Framework.Utils diff --git a/Blog/Config.hs b/Blog/Config.hs index 6a33f93..5aa5087 100644 --- a/Blog/Config.hs +++ b/Blog/Config.hs @@ -13,5 +13,6 @@ params = HP { docdir = "static", cachePath = "tmp/", sessionsDriver = "files", sessionsPath = "tmp/sessions/" +-- plugins = [] } diff --git a/Blog/Models.hs b/Blog/Models.hs index 1cc2856..99497c5 100644 --- a/Blog/Models.hs +++ b/Blog/Models.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Models where +import Debug.Trace + import qualified Data.Map as M import Database.HDBC (fromSql) import Database.HDBC.ColTypes (SqlTypeId (..)) @@ -9,6 +11,7 @@ import Framework.Types import Framework.Storage import Framework.Forms import Framework.Models +import Framework.Markdown postModel = Model { mName = "post", @@ -27,6 +30,9 @@ bComments = (/=0).(transformInt 2 id) postDate = transformString 1 id title = transformString 2 id postbody = transformString 3 id +postmarkdown = markdown2html . (transformString 3 id) + +-- tracelines x = unlines $ zipWith trace (map (("^"++).(++"$")) $ lines x) (lines x) postForm = Form { formName = "postform", diff --git a/Blog/static/blog.css b/Blog/static/blog.css index e90de7a..cefef85 100644 --- a/Blog/static/blog.css +++ b/Blog/static/blog.css @@ -4,3 +4,11 @@ border: 1px black solid; } +#postform1 { + width: 100%; +} + +#postform1 textarea { + width: 100%; +} + diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html index 47bf8ef..f85cdce 100644 --- a/Blog/templates/blogposts.html +++ b/Blog/templates/blogposts.html @@ -21,7 +21,7 @@ {%for post in posts%} <h2><a href='/blog/post/{{postid post}}'>{{title post}}</a></h2> <p><small>at {{postDate post}}</small></p> - <p>{{postbody post}}</p> + <p>{{postmarkdown post}}</p> <p><a href='/blog/post/{{postid post}}/#comments'> {%if bComments post%} {{nComments post}} комментариев diff --git a/Framework/API.hs b/Framework/API.hs index 9238d97..c875db0 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -18,7 +18,7 @@ import qualified Framework.Urls as Urls import qualified Framework.Cache as Cache import qualified Framework.SQL as SQL import Framework.Models (Model) -import Framework.HTTPServer ((<+>)) +import Framework.Response ((<+>)) -- | Runtime controller action configuration data ActionConfig = ActionConfig { diff --git a/Framework/Cookies.hs b/Framework/Cookies.hs index d36ced8..3b11e81 100644 --- a/Framework/Cookies.hs +++ b/Framework/Cookies.hs @@ -10,7 +10,7 @@ import Network.Shed.Httpd import Framework.Types import Framework.Utils import Framework.Urls -import Framework.HTTPServer +-- import Framework.HTTPServer setcookie :: String -> String -> String -> HttpHeader setcookie exp name value = "Set-Cookie" =: ((esc (name++"="++value))++"; expires="++exp) diff --git a/Framework/Forms.hs b/Framework/Forms.hs index 02100f7..1c30111 100644 --- a/Framework/Forms.hs +++ b/Framework/Forms.hs @@ -3,7 +3,8 @@ module Framework.Forms ( Inputbox, Textarea, inputbox, textarea, - tag, + HTMLTag (..), + tag, tagToHtml, toHtml, createform, refillForm, retryForm, retryEditForm, returnInvalidForm, @@ -12,7 +13,8 @@ module Framework.Forms formVars, formVarsNames, formVarsValues, notEmpty, noValidate, defValidate, - getAnyForm, getForm + getAnyForm, getForm, + FormsPlugins ) where -- $doc import Debug.Trace @@ -28,7 +30,9 @@ import Framework.Utils import Framework.Urls import Framework.API import Framework.Models -import Framework.HTTPServer (redirectG) +import Framework.Response (redirectG) + +type FormsPlugins = [Form -> Form] -- $doc -- HTML forms generation and validation. @@ -41,19 +45,65 @@ class Widget w where html :: w -- ^ A widget -> String -- ^ Widget's html \"name\" attribute -> String -- ^ Value of widget - -> String + -> HTMLTag -- | Read widget's value from string. Not used yet. wRead :: String -> WContent w -hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] "" +type HTML = [HTMLTag] +data HTMLTag = Tag { + tagName :: String, + tagAttrs :: [FormVar], + tagContent :: HTML, + mayCollapse :: Bool + } + | Text String + +data HTMLForm = HTMLForm { + visibleFields :: HTML, + hiddenFields :: HTML, + htmlFormName :: String, + formId :: String, + formAction :: String } + +tag :: String -> [FormVar] -> HTML -> HTMLTag +tag name attrs content = Tag name attrs content True + +tagE :: String -> [FormVar] -> HTML -> HTMLTag +tagE name attrs content = Tag name attrs content False + +toHtml :: HTML -> String +toHtml html = concat $ map tagToHtml html + +tagToHtml :: HTMLTag -> String +tagToHtml (Text text) = text +tagToHtml (Tag name attrs value coll) = "<"++name++(concat $ map htmlAttr attrs)++content++">" + where content | null value = if not coll + then "></"++name + else " /" + | otherwise = if coll + then ">\n"++(toHtml value)++"\n</"++name + else ">"++(toHtml value)++"</"++name + +hiddenField :: String -> String -> HTMLTag +hiddenField name value = tag "input" ["name" =: name, "value" =: value, "type" =: "hidden"] [] + +mangleName :: String -> String -> String -> String mangleName formname fid name = formname++fid++"-"++name --- | Generate <form> tag -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> tag +-- formTag :: String -> String -> String -> HTML -> String +-- formTag name fid action content = tag "form" ["method" =: "POST","action" =: action] ([fidfield, namefield] ++ content) +-- where fidfield = hiddenField "formid" fid +-- namefield = hiddenField "formname" name + +formToHtml :: HTMLForm -> String +formToHtml form = tagToHtml $ tag "form" ["method" =: "POST","action" =: (formAction form), "id" =: tagid] $ + [tag "table" [] $ (visibleFields form) ++ (hiddenFields form) ++ [fidfield, namefield, submit]] + where fidfield = hiddenField "formid" (formId form) + namefield = hiddenField "formname" (htmlFormName form) + tagid = (htmlFormName form)++(formId form) + -- | Generate form row (widget with label) formrow :: String -- ^ Form name @@ -61,8 +111,9 @@ formrow :: String -- ^ Form name -> 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)) + -> HTMLTag +formrow fname fid def cls (Field name label widget _) = tag "tr" attrs [tag "td" [] [Text itemlabel], + tag "td" [] [html widget itemname def]] where attrs = if null cls then [] else ["class" =: cls] @@ -71,18 +122,19 @@ formrow fname fid def cls (Field name label widget _) = tag "tr" attrs $ (tag "t else label itemname = mangleName fname fid name -submit :: String -submit = "<tr><td></td><td><input type='submit'/></td></tr>\n" +submit :: HTMLTag +submit = tag "tr" [] [tag "td" [] [], + tag "td" [] [tag "input" ["type" =: "submit"] []]] 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 + -> HTMLForm +createform form fid pairs action = HTMLForm vFields hFields name fid action + where vFields = map (formrow name fid "" "") (fFields form) + hFields = map ((uncurry hiddenField).mangle) pairs + name = formName form mangle (n,v) = (mangleName name fid n, v) -- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and @@ -94,14 +146,14 @@ refillFormG :: (String -> String -> String -> String) -- ^ Mangle function -> [(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 + -> HTMLForm +refillFormG mfun errfields form fid hidden pairs action = HTMLForm vFields hFields name fid action + where vFields = zipWith3 (formrow name fid) vals clss (fFields form) + hFields = map ((uncurry hiddenField).mangle) hidden 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 @@ -121,8 +173,8 @@ retryForm conf form fid pairs action = do -- 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) + 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 @@ -136,8 +188,8 @@ retryEditForm conf form fid defvals hidden action = do let filledVals = decodePairs filled let err = httpGetVar' (request conf) "invalid" "" if null err - then return (refillFormU [] form fid hidden defvals action, "") - else return (refillForm (words err) form fid hidden filledVals action, 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 -> String -> [String] -> IO Response returnInvalidForm conf form fid errs = @@ -152,36 +204,20 @@ htmlAttr (name := value) | httpEmpty value = "" emptyTags = ["textarea"] -tag :: String -> [FormVar] -> String -> String -tag name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">" - where content = if null value - then if name `elem` emptyTags - then "></"++name - else " /" - else ">"++value++"</"++name - -tag' :: String -> [FormVar] -> String -> String -tag' name attrs value = "<"++name++(concat $ map htmlAttr attrs)++content++">\n" - where content = if null value - then if name `elem` emptyTags - then "></"++name - else " /" - else ">\n"++value++"</"++name - data Inputbox = Inputbox { ibWidth :: HttpBox } inputbox = Inputbox (HB (Nothing::Maybe Int)) data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox } -textarea = Textarea (HB (Nothing::Maybe Int)) (HB (Nothing::Maybe Int)) +textarea = Textarea (HB $ Just 60) (HB $ Just 15) instance Widget Inputbox where type WContent Inputbox = String - html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] "" + html (Inputbox w) name value = tag "input" ["size" =: w, "name" =: name, "value" =: value] [] wRead = id instance Widget Textarea where type WContent Textarea = String - html (Textarea c r) name value = tag "textarea" ["cols" =: c, "rows" =: r, "name" =: name] value + html (Textarea c r) name value = tagE "textarea" ["cols" =: c, "rows" =: r, "name" =: name] [Text value] wRead = id type FormValidator = Request -> Either [String] Model diff --git a/Framework/HTTPServer.hs b/Framework/HTTPServer.hs index fcd983d..813887b 100644 --- a/Framework/HTTPServer.hs +++ b/Framework/HTTPServer.hs @@ -13,30 +13,9 @@ import Network.URI import Framework.Types import Framework.Urls import Framework.Utils +import Framework.Response import Framework.Middlewares - -response :: Int -> [HttpHeader] -> String -> Response -response code pairs body = Response code (map repackHeader $ filter notEmptyHeader pairs) body - where notEmptyHeader (_:=v) = not $ httpEmpty v - -(<+>) :: Response -> HttpHeader -> Response -(Response c hdrs b) <+> hdr = Response c (hdrs++[repackHeader hdr]) b - -(<++>) :: Response -> [HttpHeader] -> Response -(Response c old b) <++> new = Response c (old++(map repackHeader new)) b - -ok :: String -> Response -ok body = response 200 ["Content-Type" =: mime] body - where mime = "text/html" - -redirect :: String -> Response -redirect url = response 302 ["Location" =: url] "" - -redirectP :: String -> Response -redirectP url = response 301 ["Location" =: url] "" - -redirectG :: String -> [UrlParam] -> Response -redirectG url pairs = redirect $ url ? pairs +import Framework.Forms (Form,FormsPlugins) sendfile :: String -> IO Response sendfile filename = do diff --git a/Framework/Markdown.hs b/Framework/Markdown.hs new file mode 100644 index 0000000..678b50a --- /dev/null +++ b/Framework/Markdown.hs @@ -0,0 +1,11 @@ +module Framework.Markdown + (markdown2html + ) where + +import Text.Pandoc +import Text.Pandoc.CharacterReferences + +markdown2html :: String -> String +markdown2html = + decodeCharacterReferences .(writeHtmlString defaultWriterOptions) . readMarkdown defaultParserState . filter (/='\r') + diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 6c86ff2..e2068ff 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -48,17 +48,17 @@ genericPager pg conf perpage q params model = do -- | Simple pager HTML generator genpager :: Pager -genpager rq pages page = tag "p" ["class" =: "pager"] (firstlink++prevlink++(concat $ map onepage pagelist)++nextlink++lastlink) +genpager rq pages page = tagToHtml $ tag "p" ["class" =: "pager"] (firstlink++prevlink++(map onepage pagelist)++nextlink++lastlink) where pagelist = [1..pages] - onepage n | n==page = tag "span" [] (show n) - | otherwise = tag "a" ["href" =: (pagelink n)] (show n) + onepage n | n==page = tag "span" [] [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)] "<" - nextlink | page==pages = "" - | otherwise = tag "a" ["href" =: (pagelink $ page+1)] ">" - firstlink | page==1 = "" - | otherwise = tag "a" ["href" =: (pagelink 1)] "<<" - lastlink | page==pages = "" - | otherwise = tag "a" ["href" =: (pagelink pages)] ">>" + prevlink | page==1 = [] + | otherwise = [tag "a" ["href" =: (pagelink $ page-1)] [Text "<"]] + nextlink | page==pages = [] + | otherwise = [tag "a" ["href" =: (pagelink $ page+1)] [Text ">"]] + firstlink | page==1 = [] + | otherwise = [tag "a" ["href" =: (pagelink 1)] [Text "<<"]] + lastlink | page==pages = [] + | otherwise = [tag "a" ["href" =: (pagelink pages)] [Text ">>"]] diff --git a/Framework/Response.hs b/Framework/Response.hs new file mode 100644 index 0000000..53974c9 --- /dev/null +++ b/Framework/Response.hs @@ -0,0 +1,34 @@ +module Framework.Response where + +import qualified Network.Shed.Httpd as Httpd + +import Framework.Types +import Framework.Utils +import Framework.Urls ((?)) + +------------------------------------------------------------------------------------------------------- +-- * Make a Response +-- +response :: Int -> [HttpHeader] -> String -> Httpd.Response +response code pairs body = Httpd.Response code (map repackHeader $ filter notEmptyHeader pairs) body + where notEmptyHeader (_:=v) = not $ httpEmpty v + +ok :: String -> Httpd.Response +ok body = response 200 ["Content-Type" =: mime] body + where mime = "text/html" + +redirect :: String -> Httpd.Response +redirect url = response 302 ["Location" =: url] "" + +redirectP :: String -> Httpd.Response +redirectP url = response 301 ["Location" =: url] "" + +redirectG :: String -> [UrlParam] -> Httpd.Response +redirectG url pairs = redirect $ url ? pairs + +(<+>) :: Httpd.Response -> HttpHeader -> Httpd.Response +(Httpd.Response c hdrs b) <+> hdr = Httpd.Response c (hdrs++[repackHeader hdr]) b + +(<++>) :: Httpd.Response -> [HttpHeader] -> Httpd.Response +(Httpd.Response c old b) <++> new = Httpd.Response c (old++(map repackHeader new)) b + diff --git a/Framework/Sessions.hs b/Framework/Sessions.hs index 51fa907..a97d926 100644 --- a/Framework/Sessions.hs +++ b/Framework/Sessions.hs @@ -23,7 +23,7 @@ import Network.Shed.Httpd(Request) import Framework.Types import Framework.Utils import Framework.Cookies -import Framework.HTTPServer +-- import Framework.HTTPServer type SessionID = String type SessionMap = M.Map String String diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index f730db9..38c4f2b 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -8,7 +8,7 @@ module Framework.TEngine.TemplateUtil import qualified Data.Map as M import Network.Shed.Httpd -import Framework.HTTPServer (ok) +import Framework.Response (ok) import Framework.TEngine.Templates (render) import Framework.Types import Framework.API diff --git a/Framework/Types.hs b/Framework/Types.hs index f263bdd..d26a9af 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -12,35 +12,12 @@ import qualified Database.HDBC as D -- type Channel = Handle type S = String -type URLParts = [String] -type StrAction = HttpActionParams -> Request -> String -> Maybe (IO Response) -type ManyStrAction = HttpActionParams -> Request -> URLParts -> Maybe (IO Response) -type HttpAction = HttpActionParams -> Request -> IO Response - -data URLConf = Action HttpAction - | OneOf URLConf URLConf - | Function StrAction - | Prefix String URLConf - | Regexp String URLConf - | RegexpFun String StrAction - | ManyRegexpFun URLParts URLParts ManyStrAction - | After URLConf URLConf - -instance Show URLConf where - show (Action _) = "Some action" - show (OneOf x y) = (show x)++"\n| "++(show y) - show (Function _) = "Some function" - show (Prefix s u) = s++" --> "++(show u) - show (Regexp s u) = s++" --> "++(show u) - show (RegexpFun s _) = s++" --> Some function" - show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function" - show (After u v) = (show u)++", then "++(show v) ------------------------------------------------------------------------------------------- data HttpActionParams = HP { docdir :: String, - hLog :: Channel, + hLog :: Handle, dbDriver :: String, dbPath :: String, cacheDriver :: String, diff --git a/Framework/Urls.hs b/Framework/Urls.hs index 61a88ae..11d701d 100644 --- a/Framework/Urls.hs +++ b/Framework/Urls.hs @@ -13,6 +13,30 @@ import Data.List import Framework.Utils import Framework.Types +type URLParts = [String] +type StrAction = HttpActionParams -> Request -> String -> Maybe (IO Response) +type ManyStrAction = HttpActionParams -> Request -> URLParts -> Maybe (IO Response) +type HttpAction = HttpActionParams -> Request -> IO Response + +data URLConf = Action HttpAction + | OneOf URLConf URLConf + | Function StrAction + | Prefix String URLConf + | Regexp String URLConf + | RegexpFun String StrAction + | ManyRegexpFun URLParts URLParts ManyStrAction + | After URLConf URLConf + +instance Show URLConf where + show (Action _) = "Some action" + show (OneOf x y) = (show x)++"\n| "++(show y) + show (Function _) = "Some function" + show (Prefix s u) = s++" --> "++(show u) + show (Regexp s u) = s++" --> "++(show u) + show (RegexpFun s _) = s++" --> Some function" + show (ManyRegexpFun _ rs _) = (concat $ intersperse "/" rs)++" --> Some function" + show (After u v) = (show u)++", then "++(show v) + urlSplit :: URI -> URLParts urlSplit uri = filter (/="") $ splitWith (=='/') url -- (url++slash) where url = uriPath uri