Commits

Luke Plant  committed e478875

Beginnings of admin form for blog Posts.

  • Participants
  • Parent commits 71a8a39

Comments (0)

Files changed (5)

File src/Blog/Forms.hs

 import Ella.GenUtils (exactParse, getTimestamp)
 import Ella.Param (captureOrDefault, Param(..))
 import Data.String.Utils (strip)
+import qualified Blog.Category as Ct
 import qualified Blog.Comment as Cm
 import qualified Blog.Post as P
 import qualified Blog.Settings as Settings
 import qualified Data.Map as Map
 import qualified Ella.Forms.Widgets.RadioButtonList as RBL
+import qualified Ella.Forms.Widgets.OptionList as OL
 import qualified Text.XHtml as X
 
 -- Widgets
-commentAllowedFormats =  [Plaintext, RST]
-
 formatNames = Map.fromList [ (Plaintext, "Plain text")
                            , (RST, "Restructured text")
                            , (Rawhtml, "HTML")
                            ]
 
-formatWidget formats = RBL.RadioButtonList { value = ""
+formatWidget formats = RBL.RadioButtonList { selectedValue = ""
                                            , name = "format"
                                            , identifier = "id_format"
                                            , values = map (show . fromEnum) formats
                                            , captions = map (X.toHtml . fromJust . (\f -> Map.lookup f formatNames)) formats
                                            }
+
+commentAllowedFormats =  [Plaintext, RST]
+
 formatWidgetForComment c  = setVal (show $ fromEnum $ Cm.format c) (formatWidget commentAllowedFormats)
 
+postAllowedFormats = [Plaintext, RST, Rawhtml]
+
+formatWidgetForPost p = setVal (show $ fromEnum $ P.format p) (formatWidget postAllowedFormats)
+
+categoriesWidget categories = OL.OptionList { selectedValues = []
+                                            , name = "categories"
+                                            , identifier = "id_categories"
+                                            , values = map (show . Ct.uid) categories
+                                            , captions = map Ct.name categories
+                                            , multiple = True
+                                            , size = 10
+                                            }
+
+categoriesWidgetForPost :: [Int] -> [Ct.Category] -> OL.OptionList
+categoriesWidgetForPost catids categories = setVal (map show catids) (categoriesWidget categories)
+
 -- | Enum for the different stages of submitting a comment
 data CommentStage = NoComment
                   | CommentPreview
             else return (loginData, Map.fromList [("password", "Password not correct.")])
        else do
          return (loginData, Map.fromList errors)
+
+emptyPost = P.Post { uid = undefined
+                   , title = ""
+                   , slug = undefined
+                   , post_raw = ""
+                   , post_formatted = undefined
+                   , summary_raw = ""
+                   , summary_formatted = undefined
+                   , format = RST
+                   , timestamp = undefined
+                   , comments_open = True
+                   }

File src/Blog/Model.hs

                   , addComment
                   , createUser
                   , getPostBySlug
+                  , getPostById
                   , getRecentPosts
                   , getCategoriesForPost
                   , getCommentsForPost
     [] -> return Nothing
     (postdata:_) -> return $ Just $ makePost postdata
 
+getPostById :: (IConnection conn) => conn -> Int -> IO (Maybe P.Post)
+getPostById cn postid = do
+  res <- quickQuery' cn getPostByIdQuery [toSql postid]
+  case res of
+    [] -> return Nothing
+    (postdata:_) -> return $ Just $ makePost postdata
+
 getRecentPosts :: (IConnection conn) => conn -> Int -> IO ([P.Post], Bool)
 getRecentPosts cn page = do
   (res,more) <- pagedQuery cn getRecentPostsQuery [] page Settings.post_page_size

File src/Blog/Routes.hs

          , "login/" <+/> empty                        //-> loginView              $ []
          , "logout/" <+/> empty                       //-> logoutView             $ []
          , "admin/category/" <+/> empty               //-> adminCategories        $ [adminRequired]
+         , "admin/post/new/" <+/> empty               //-> adminNewPost           $ [adminRequired]
+         , "admin/post/edit/" <+/> anyParam           //-> adminEditPost          $ [adminRequired]
          , "debug/" <+/> anyParam                     //-> debug                  $ []
          ]

File src/Blog/Templates.hs

 import Blog.Links
 import Blog.Utils (escapeHtmlStringT)
 import Data.Maybe (fromJust)
-import Ella.Forms.Base
 import Ella.GenUtils (utf8)
 import System.Locale (defaultTimeLocale)
 import System.Time (toUTCTime, formatCalendarTime)

File src/Blog/Views.hs

 -- which has pure functions that generally return Html.
 
 import Blog.DB (connect)
-import Blog.Forms (CommentStage(..), validateComment, emptyComment, emptyLoginData, validateLogin, initialCommentExtra, formatWidgetForComment)
+import Blog.Forms
 import Blog.Globals (mkCsrfField)
 import Blog.Links
 import Blog.Model
           ("message", message)
           ("showMessage", length message > 0)
          )
-    where
+  where
       handlePost req cn =
           if requestMethod req == "POST"
           then if isJust (getPOST req "save")
                     else return ""
           else return ""
 
+adminEditPost post_id req = do
+  cn <- connect
+  m_post <- getPostById cn post_id
+  case m_post of
+    Just p -> adminEditPost' p False cn req
+    Nothing -> return404 req
+
+adminNewPost req = do
+  cn <- connect
+  adminEditPost' emptyPost True cn req
+
+adminEditPost' post isNew cn req = do
+  categories <- getCategories cn
+  postCategories <- if isNew then return [] else getCategoriesForPost cn post
+  case requestMethod req of
+    "GET" ->  output post (map Ct.uid postCategories) categories
+    "POST" -> output post (map Ct.uid postCategories) categories
+              -- TODO
+              -- handle 'submit'
+              --   - with validation
+              --   - and redirection afterwards if successful
+              -- handle 'preview'
+              -- handle 'delete'
+  where
+      output postData postCatIds categories = do
+        t <- get_template "admin_post"
+        return $ Just $ standardResponseTT req $
+                                   (renderf t
+                                    ("post", postData)
+                                    ("categoriesWidget", X.toHtml $ categoriesWidgetForPost postCatIds categories)
+                                    ("formatWidget", X.toHtml $ formatWidgetForPost postData)
+                                    ("isNew", isNew)
+                                    ("pagetitle", if isNew then "Add post" else "Edit post")
+                                   )
+
 createLoginCookies loginData timestamp =
   let username = fromJust $ Map.lookup "username" loginData
       password = fromJust $ Map.lookup "password" loginData