diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 8fcdac9..728d8a6 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -1,14 +1,13 @@ import System.IO -import Network.Shed.Httpd import Database.HDBC (SqlValue(..),fromSql) import qualified Data.Map as M import Control.Monad +import Network.HTTP import Framework.Types import Framework.API import Framework.SQL --- import Framework.HTTPServer import Framework.Http.Response import Framework.TEngine.TemplateUtil import Framework.Urls @@ -61,12 +60,12 @@ invalidatePostsCache conf = do newpost :: HttpAction newpost conf = do - case reqMethod (request conf) of - "GET" -> + case rqMethod (request conf) of + GET -> do (form,err) <- retryForm conf postForm "1" [] url return $ renderToResponse "newpost.html" [("form", C form), ("invalid", C err)] - "POST" -> do + POST -> do let (d,_) = getForm allForms (request conf) "postform" case d of Right post -> let ptitle = post -:> "title" @@ -80,8 +79,8 @@ newpost conf = do editpost :: StrAction editpost conf sid = Just $ - case reqMethod (request conf) of - "GET" -> + case rqMethod (request conf) of + GET -> do posts <- querySQL' conf ((table postModel) `restrict` ("id" :==: "?")) [SqlInt32 pid] postModel let post = head posts let ptitle = post -:> "title" @@ -89,7 +88,7 @@ editpost conf sid = Just $ (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 + POST -> do let (d,_) = getForm allForms (request conf) "postform" case d of Right post -> let ptitle = post -:> "title" @@ -106,8 +105,8 @@ editpost conf sid = Just $ onepost :: StrAction onepost conf sid = Just $ do (form,err) <- retryForm conf commentForm "1" [] url - case reqMethod (request conf) of - "GET" -> do + case rqMethod (request conf) 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" "" @@ -116,7 +115,7 @@ onepost conf sid = Just $ do ("comments", C comments), ("message", C message), ("form", C form)] - "POST" -> do + POST -> do let (d,_) = getForm allForms (request conf) "comment" case d of Right comment -> diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index ac2f5f5..6287309 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -84,8 +84,8 @@ submit = tag "tr" [] [tag "td" [] [], -- | Render field=value htmlAttr :: FormVar -> String -htmlAttr (name := value) | httpEmpty value = "" - | otherwise = " "++name++"='"++(httpShow value)++"'" +htmlAttr (name := value) | null value = "" + | otherwise = " "++name++"='"++value++"'" -- | Create HTMLForm from Form description createform :: Form -- ^ Form description @@ -99,20 +99,20 @@ createform form fid pairs action = HTMLForm vFields hFields name fid action name = formName form mangle (n,v) = (mangleName name fid n, v) -data Inputbox = Inputbox { ibWidth :: HttpBox } -inputbox = Inputbox (HB (Nothing::Maybe Int)) +data Inputbox = Inputbox { ibWidth :: Maybe Int } +inputbox = Inputbox Nothing -data Textarea = Textarea { tbCols :: HttpBox, tbRows :: HttpBox } -textarea = Textarea (HB $ Just 60) (HB $ Just 15) +data Textarea = Textarea { tbCols :: Maybe Int, tbRows :: Maybe Int } +textarea = Textarea (Just 60) (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" := show w, "name" := name, "value" := value] [] wRead = id instance Widget Textarea where type WContent Textarea = String - html (Textarea c r) name value = tagE "textarea" ["cols" =: c, "rows" =: r, "name" =: name] [Text value] + html (Textarea c r) name value = tagE "textarea" ["cols" := show c, "rows" := show r, "name" := name] [Text value] wRead = id diff --git a/Framework/Pager.hs b/Framework/Pager.hs index 6e7c319..a9a0d5c 100644 --- a/Framework/Pager.hs +++ b/Framework/Pager.hs @@ -5,7 +5,7 @@ module Framework.Pager ) where import Database.HDBC (SqlValue (..), fromSql) -import Network.Shed.Httpd (Request) +import Network.HTTP import Framework.Forms.Types import Framework.Forms.HTML @@ -17,7 +17,7 @@ import Framework.Types -- | Represents pager HTML generator -type Pager = Request -> Int -> Int -> String +type Pager = Request String -> Int -> Int -> String -- | Simple pager pager :: ActionConfig-> Int-> Query-> [SqlValue]-> Model-> IO ([Model], String) diff --git a/Framework/TEngine/TemplateUtil.hs b/Framework/TEngine/TemplateUtil.hs index acdabd2..fb69e89 100644 --- a/Framework/TEngine/TemplateUtil.hs +++ b/Framework/TEngine/TemplateUtil.hs @@ -6,7 +6,7 @@ module Framework.TEngine.TemplateUtil where import qualified Data.Map as M -import Network.Shed.Httpd +import Network.HTTP import Framework.Http.Response (ok) import Framework.TEngine.Templates (render) @@ -18,10 +18,10 @@ instance (Ord k, Show k,Show v, Read k, Read v) => Serializable (M.Map k v) wher toString = show fromString = read -renderToResponse :: String -> [(String,TContainer)] -> Response +renderToResponse :: String -> [(String,TContainer)] -> Response String renderToResponse name pairs = ok $! render name (M.fromList pairs) -renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO Response +renderToResponseC :: (Serializable k) => ActionConfig -> k -> String -> [(String,TContainer)] -> IO (Response String) renderToResponseC (ActionConfig{cacheBackend=b}) key name pairs = do v <- cached b ("render:"++name) key (render name) (M.fromList pairs) return $ ok v