Commits

Luke Plant committed 574cc73

Implemented admin page for editing/adding/deleting posts

  • Participants
  • Parent commits 5b2e07d

Comments (0)

Files changed (5)

File src/Blog/Forms.hs

 import Blog.Formats (Format(..), getFormatter)
 import Blog.Model (checkPassword)
 import Control.Monad (liftM)
-import Data.Maybe (fromJust, isNothing)
+import Data.Maybe (fromJust, isNothing, catMaybes)
 import Ella.Forms.Base
 import Ella.GenUtils (exactParse, getTimestamp)
 import Ella.Param (captureOrDefault, Param(..))
+import Ella.Request (getPOST, getPOSTlist, hasPOST)
 import Data.String.Utils (strip)
 import qualified Blog.Category as Ct
 import qualified Blog.Comment as Cm
                    , timestamp = undefined
                    , comments_open = True
                    }
+
+-- | Extract a 'post', the 'post categories' and any errors
+-- from the POST request
+validatePost req basePost = do
+  let title = getPOST req "title" `captureOrDefault` ""
+  let categories = catMaybes $ map capture $ getPOSTlist req "categories" :: [Int]
+  let summary_raw = getPOST req "summary_raw" `captureOrDefault` ""
+  let post_raw = getPOST req "post_raw" `captureOrDefault` ""
+  let format = getPOST req "format" `captureOrDefault` Plaintext
+  let comments_open = hasPOST req "comments_open"
+  let tests = [ (null title,
+                 ("title", "'Title' is a required field."))
+              , (null summary_raw,
+                  ("summary", "'Summary' is a required field."))
+              , (null post_raw,
+                 ("post", "'Full post' is a required field."))
+              ]
+  let errors = map snd $ filter fst $ tests
+  return (basePost { P.title = title
+                   , P.summary_raw = summary_raw
+                   , P.summary_formatted = getFormatter Plaintext $ summary_raw
+                   , P.post_raw = post_raw
+                   , P.post_formatted = getFormatter format $ post_raw
+                   , P.format = format
+                   , P.comments_open = comments_open
+                   }
+         , categories
+         , errors
+         )

File src/Blog/Model.hs

 module Blog.Model ( addPost
+                  , updatePost
+                  , deletePost
                   , addCategory
                   , updateCategory
                   , deleteCategory
                      , toSql $ P.comments_open p
                      ]
 
-addPost cn p = do theslug <- makePostSlug cn p
-                  let p2 = p { P.slug = theslug }
-                  DB.doInsert cn "posts" postColumnNames (postColumnValues p2)
-                  newid <- getDbId cn
-                  return p2 { P.uid = newid }
+addPost cn p catIds = do
+  theslug <- makePostSlug cn p
+  let p2 = p { P.slug = theslug }
+  DB.doInsert cn "posts" postColumnNames (postColumnValues p2)
+  newid <- getDbId cn
+  setPostCategories cn newid catIds
+  return p2 { P.uid = newid }
 
 makePostSlug cn p = makeSlugGeneric cn (P.title p) "posts"
 
+updatePost cn p catIds = do
+  DB.doUpdate cn "posts" postColumnNames (postColumnValues p)
+        "WHERE id = ?" [toSql $ P.uid p]
+  setPostCategories cn (P.uid p) catIds
+  return p
+
+deletePost cn uid = do
+  DB.doDelete cn "post_categories" "WHERE post_id = ?" [toSql uid]
+  DB.doDelete cn "posts" "WHERE id = ?" [toSql uid]
 
 -- category table
 categoryColumnNames = [ "name"
         "WHERE id = ?" [ toSql $ Ct.uid c]
 
 deleteCategory cn uid = do
+  DB.doDelete cn "post_categories" "WHERE category_id = ?" [toSql $ uid]
   DB.doDelete cn "categories" "WHERE id = ?" [toSql $ uid]
-  DB.doDelete cn "post_categories" "WHERE category_id = ?" [toSql $ uid]
 
+-- post_categories tables
+addPostCategory :: (IConnection conn) => conn -> (Int, Int) -> IO (Int, Int)
 addPostCategory cn pc = do { DB.doInsert cn "post_categories"
                              ["post_id",
                               "category_id"]
                              [toSql $ fst pc,
                               toSql $ snd pc];
                              return pc; }
+setPostCategories cn postId catIds = do
+  DB.doDelete cn "post_categories" "WHERE post_id = ?" [toSql postId]
+  mapM_ (\c -> addPostCategory cn (postId, c)) catIds
+
 
 -- comment table
 commentColumnNames = [ "post_id"

File src/Blog/Views.hs

 import Ella.Request
 import Ella.Response
 import Ella.Utils (addHtml)
-import Maybe (fromMaybe, isJust, fromJust)
+import Maybe (fromMaybe, isJust, fromJust, catMaybes)
 import System.Time (ClockTime(..), toUTCTime)
 import Text.StringTemplate
 import Text.StringTemplate.GenericStandard
 import qualified Blog.Category as Ct
+import qualified Blog.Post as P
 import qualified Blog.Settings as Settings
 import qualified Data.Map as Map
 import qualified Data.ByteString.Lazy as LB
   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'
-              --   - same validation - can't show preview if invalid
-              -- handle 'delete'
+    "GET" ->  output post (map Ct.uid postCategories) categories "start" []
+    "POST" -> do
+      let mode = head $ map fst $ filter snd $  [ ("submit", hasPOST req "submit")
+                                                , ("delete", hasPOST req "delete")
+                                                -- use preview as default, for simplicity
+                                                , ("preview", True)
+                                                ]
+      if mode == "delete"
+        then do
+          deletePost cn (P.uid post)
+          return $ Just $ redirectResponse adminMenuUrl
+        else do
+          (postData, postCatIds, postErrors) <- validatePost req post
+          if null postErrors
+            then
+              if mode == "submit"
+                then do
+                  if isNew
+                    then do
+                      -- Set timestamp here, because we don't want to do it in
+                      -- validatePost (we would need to pass in isNew)
+                      ts <- getTimestamp
+                      let newPost = postData { P.timestamp = ts }
+                      addPost cn newPost postCatIds
+                    else updatePost cn postData postCatIds
+                  return $ Just $ redirectResponse adminMenuUrl
+              else do
+                -- mode == "preview"
+                output postData postCatIds categories mode postErrors
+            else
+                -- invalid
+                output postData postCatIds categories "invalid" postErrors
   where
-      output postData postCatIds categories = do
-        t <- get_template "admin_post"
-        return $ Just $ standardResponseTT req $
+    output :: P.Post -> [Int] -> [Ct.Category] -> String -> [(String, String)] -> IO (Maybe Response)
+    output postData postCatIds categories mode errors =
+        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")
+                                    ("mode", mode)
+                                    ("errors", errors)
+                                    ("showErrors", not $ null errors)
+                                    ("showPreview", mode == "preview")
                                    )
 
 createLoginCookies loginData timestamp =

File src/Migrate.hs

 -- Misc fixes
 -- Titles of all posts in category 'articles' have HTML in them, which is difficult to fix
 -- up.  They are only announcements, so we just delete.
-deletePost = "DELETE FROM posts WHERE id = ?;";
 deleteArticlePosts cn = do
   Just cat <- getCategoryBySlug cn "articles"
   (posts, False) <- getPostsForCategory cn cat 1 -- there is only one page worth
   deleteCategory cn (C.uid cat)
-  mapM_ (\x -> quickQuery cn deletePost [toSql $ P.uid x]) posts
+  mapM_ (\x -> deletePost cn $ P.uid x) posts
 
 
 -- Main
   newCats <- writeItems cn addCategory origCats
   -- Posts
   origPosts <- readPosts
-  newPosts <- writeItems cn addPost origPosts
+  newPosts <- writeItems cn (\cn p -> addPost cn p []) origPosts
   -- we need the new/old IDs of posts/categories to rewrite comments tables
   -- and the post/categories m2m
   let post_id_map = Map.fromList $ zip (map P.uid origPosts) (map P.uid newPosts)

File src/templates/admin_post.st

+$pagestart()$
+<h1>$pagetitle$</h1>
+
+$if(showErrors)$
+  $displayerrors(errors=errors)$
+$endif$
+
+$if(showPreview)$
+<p>Preview:</p>
+<div class="postpreview">
+<h1 class="posttitle">$post.title$</h1>
+<div class="post">
+  $post.post_formatted:noescape()$
+</div>
+</div>
+$endif$
+
+<form action="." method="POST">
+$csrffield:noescape()$
+<table>
+  <tr>
+    <td><label for="id_title">Title:</label></td>
+    <td><input type="text" id="id_title" name="title" value="$post.title$" size=40></td>
+  </tr>
+  <tr>
+    <td><label for="id_categories">Categories:</label></td>
+    <td>
+      $categoriesWidget:noescape()$
+    </td>
+  </tr>
+  <tr>
+    <td colspan="2">
+      <label for="id_summary">Summary</label><br />
+      <textarea id="id_summary_raw" name="summary_raw" cols="80" rows="5">$post.summary_raw$</textarea>
+    </td>
+  </tr>
+    <td colspan="2">
+      <label for="id_text">Full post</label><br />
+      <textarea id="id_post_raw" name="post_raw" cols="80" rows="30">$post.post_raw$</textarea>
+    </td>
+  </tr>
+  <tr>
+    <td><label for="id_format">Format:</label></td>
+    <td>
+      $formatWidget:noescape()$
+    </td>
+  </tr>
+  <tr>
+    <td><label for="id_comments_open">Open for comments:</label></td>
+    <td>
+      <input type="checkbox" name="comments_open" $if(post.comments_open)$checked="checked"$endif$ >
+    </td>
+  </tr>
+</table>
+
+<br>
+<input type="submit" name="submit" value="Post"> <input type="submit" name="preview" value="Preview"><br>
+
+$if(!isNew)$
+<br><br>
+<input type="submit" name="delete" value="Delete post">
+$endif$
+
+</form>
+
+$pageend()$