Added the ability to edit and delete posts

backend/app/Main.hs

@@ -90,18 +90,19 @@ getPostsInCategory c cat page = do
 
 getPostContent :: IConnection t => t -> Int -> IO (Maybe JSValue)
 getPostContent c pid = do
-  getPost <- prepare c "SELECT title, catid, content FROM posts WHERE postid = ?;"
+  getPost <- prepare c "SELECT title, catid, content, subtext FROM posts WHERE postid = ?;"
   execute getPost [toSql (pid)]
   result <- fetchAllRows getPost
 
   case result of
-    (t:cid:con:[]):[] -> do
+    (t:cid:con:sub:[]):[] -> do
       category <- getCategory c $ fromSql cid
       let title = ("title", toJSString $ fromSql t)
       let content = ("content", toJSString $ fromSql con)
       let cat = ("category", toJSString category)
       let catid = ("catid", toJSString $ fromSql cid)
-      return $ Just $ showJSON $ toJSObject [title, content, cat, catid];
+      let subtext = ("subtext", toJSString $ fromSql sub)
+      return $ Just $ showJSON $ toJSObject [title, content, cat, catid, subtext];
     _ -> fail "Post does not exist!"
 
 hexOfBS :: B.ByteString -> String
@@ -180,12 +181,11 @@ attemptCreatePost c authtoken username title subtext content category = do
   case cookieValid of
     False -> return Nothing
     True -> do
-      -- First we should probably validate that the category actually exists
+      -- Create the category if it doesn't exist
       result <- createCategoryIfNotExist c category
       case result of
         Nothing -> do return Nothing
         Just catid -> do
-          -- If we're here, we know the category does actually exist
           addPost <- prepare c "INSERT INTO posts(catid, title, subtext, content) VALUES(?, ?, ?, ?) RETURNING postid;"
           execute addPost [toSql catid, toSql title, toSql subtext, toSql content]
           post <- fetchAllRows addPost
@@ -210,6 +210,77 @@ handleCreatePost c = do
     Just pid -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("postid", toJSString pid)]
     Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("postid", toJSString "")]
 
+attemptEditPost :: IConnection t => t -> String -> String -> String -> String -> String -> String -> String -> IO (Maybe String)
+attemptEditPost c authtoken username title subtext content category id = do
+  cookieValid <- validateCookie c authtoken username
+  case cookieValid of
+    False -> return Nothing
+    True -> do
+      -- Determine if the postid we're trying to update exists
+      postExists <- prepare c "SELECT * FROM posts WHERE postid = ?;"
+      execute postExists [toSql id]
+      exists <- fetchAllRows postExists
+      
+      case exists of
+        [] -> return Nothing
+        [_] -> do
+          -- Create the category if it doesn't exist
+          result <- createCategoryIfNotExist c category
+          case result of
+            Nothing -> do return Nothing
+            Just catid -> do
+              addPost <- prepare c "UPDATE posts SET catid = ?, title = ?, subtext = ?, content = ? WHERE postid = ?"
+              execute addPost [toSql catid, toSql title, toSql subtext, toSql content, toSql id]
+              commit c
+              return $ Just id
+
+handleEditPost :: IConnection t => t -> ServerPart Response
+handleEditPost c = do
+  methodM POST
+  authtoken <- lookCookieValue "token"
+  username <- look "username"
+  title <- look "title"
+  subtext <- look "subtext"
+  content <- look "content"
+  category <- look "category"
+  postid <- look "id"
+
+  success <- lift $ attemptEditPost c authtoken username title subtext content category postid
+  case success of 
+    Just pid -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("postid", toJSString pid)]
+    Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("postid", toJSString "")]
+
+attemptDeletePost :: IConnection t => t -> String -> String -> String -> IO (Bool)
+attemptDeletePost c authtoken username id = do
+  cookieValid <- validateCookie c authtoken username
+  case cookieValid of
+    False -> return False
+    True -> do
+      -- Determine if the postid we're trying to update exists
+      postExists <- prepare c "SELECT * FROM posts WHERE postid = ?;"
+      execute postExists [toSql id]
+      exists <- fetchAllRows postExists
+      
+      case exists of
+        [] -> return False
+        [_] -> do
+          deletePost <- prepare c "DELETE FROM posts WHERE postid = ?;"
+          execute deletePost [toSql id]
+          commit c
+          return True
+
+handleDeletePost :: IConnection t => t -> ServerPart Response
+handleDeletePost c = do
+  methodM POST
+  authtoken <- lookCookieValue "token"
+  username <- look "username"
+  postid <- look "id"
+
+  success <- lift $ attemptDeletePost c authtoken username postid
+  case success of 
+    True -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true")]
+    False -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false")]
+
 attemptWhoami :: IConnection t => t -> String -> IO (Maybe String)
 attemptWhoami c at = do
   getUser <- prepare c "SELECT username FROM users WHERE authtoken = ?;"
@@ -253,5 +324,7 @@ main = do
          , dir "v1" $ dir "logout" $ do
             expireCookie "token"
             ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true")]
+         , dir "v1" $ dir "editPost" $ handleEditPost c
+         , dir "v1" $ dir "deletePost" $ handleDeletePost c
          , notFound $ toResponse "Endpoint does not exist"
          ]

docker-compose.yml

@@ -18,7 +18,6 @@ services:
 
   database:
     image: postgres
-    restart: unless-stopped
     environment: 
       - POSTGRES_PASSWORD=root
       - POSTGRES_USER=blog

frontend/src/Main.elm

@@ -34,7 +34,8 @@ type alias Post = {
   id: String,
   category: Category,
   title: String,
-  subtext: String
+  subtext: String,
+  content: String
   }
 
 type Route
@@ -45,6 +46,7 @@ type Route
   | LoginView
   | LogoutView
   | CreatePostView
+  | EditPostView
 
 routeParser : P.Parser (Route -> a) a
 routeParser =
@@ -61,16 +63,16 @@ routeParser =
 processPostListing : Decoder (List Post)
 processPostListing = 
   Json.Decode.list (
-    map5(\a->\b->\c->\d->\e-> Post a (Category b c) d e) (field "id" string) (field "catid" string) (field "category" string) (field "title" string) (field "subtext" string)
+    map5(\a->\b->\c->\d->\e-> Post a (Category b c) d e "") (field "id" string) (field "catid" string) (field "category" string) (field "title" string) (field "subtext" string)
   )
 
 processCategoryListing : Decoder (List Category)
 processCategoryListing =
   Json.Decode.list (map2 Category (field "id" string) (field "name" string))
 
-processPost : Decoder (String, String, String)
+processPost : Decoder {title: String, content: String, subtext: String, category: Category}
 processPost = 
-  map3 (\a -> \b -> \c -> (a,b,c)) (field "title" string) (field "content" string) (field "category" string)
+  map5 (\a -> \b -> \c -> \d -> \e -> {title=a,content=b,subtext=e,category=(Category c d)}) (field "title" string) (field "content" string) (field "catid" string) (field "category" string) (field "subtext" string)
 
 processCategory : Decoder (String, List Post)
 processCategory =
@@ -82,6 +84,12 @@ processLogout =
     "true" -> True
     _ -> False) (field "success" string)
 
+processDeletePost : Decoder (Bool)
+processDeletePost = 
+  Json.Decode.map (\a -> case a of 
+    "true" -> True
+    _ -> False) (field "success" string)
+
 processLogin : Decoder (Maybe User)
 processLogin =
   map2 (\a->\b->case a of 
@@ -94,6 +102,12 @@ processCreatePost =
     "true" -> Just b
     _ -> Nothing) (field "success" string) (field "postid" string)
 
+processEditPost : Decoder (Maybe String)
+processEditPost =
+  map2 (\a->\b->case a of 
+    "true" -> Just b
+    _ -> Nothing) (field "success" string) (field "postid" string)
+
 processWhoami : Decoder (Maybe String)
 processWhoami =
   map2 (\a->\b->case a of 
@@ -127,10 +141,7 @@ type alias Model = {
   username: String,
   password: String,
   user: Maybe User,
-  title: String,
+  post: Post
-  subtext: String,
-  content: String,
-  category: String
   }
 
 type Msg
@@ -138,7 +149,7 @@ type Msg
   | UrlChanged Url.Url
   | GotPosts (Result Http.Error (List Post))
   | GotCategories (Result Http.Error (List Category))
-  | GotPost (Result Http.Error (String, String, String))
+  | GotPost (Result Http.Error {title: String, content: String, subtext: String, category: Category})
   | GotCategory (Result Http.Error (String, List Post))
   | LoginResult (Result Http.Error (Maybe User))
   | UsernameUpdate String
@@ -152,7 +163,13 @@ type Msg
   | CategoryUpdate String
   | CreatePost
   | CreatePostResult (Result Http.Error (Maybe String))
+  | DeletePostResult (Result Http.Error Bool)
+  | EditPostResult (Result Http.Error (Maybe String))
   | GotWhoami (Result Http.Error (Maybe String))
+  | GotoEditPost
+  | GotoDeletePost
+  | EditPost
+  | DeletePost
 
 init : () -> Url.Url -> Browser.Navigation.Key -> (Model, Cmd Msg)
 init _ url key =
@@ -161,7 +178,7 @@ init _ url key =
       header = "", body = "", footer = "", pinnedPosts = [], 
       posts = [], route = r, key = key, errMessage = Nothing,
       username = "", password = "", user = Nothing,
-      title = "", subtext = "", content = "", category = "Blog Post"
+      post = Post "" (Category "" "") "" "" ""
     },
     Http.get {url = "/v1/whoami", expect = Http.expectJson GotWhoami processWhoami}
   )
@@ -176,11 +193,16 @@ update msg model =
     UrlChanged req ->
       (
         let r = P.parse routeParser req in
-        ({model | route = r}, messageOfRoute r)
+        let imodel = case r of
+              Just CreatePostView -> {model | post = Post "" (Category "" "") "" "" ""}
+              Just (PostView p) -> let post = model.post in {model | post = {post | id = p}}
+              _ -> model
+        in
+        ({imodel | route = r}, messageOfRoute r)
       )
     GotPosts (Ok l) -> ({model | errMessage = Nothing, posts = l}, Cmd.none)
     GotPosts (Err _) -> ({model | errMessage = Just "Failed to load posts"}, Cmd.none)
-    GotPost (Ok (title, content, category)) -> ({model | errMessage = Nothing, header = title, body = content, footer = category}, Cmd.none)
+    GotPost (Ok {title, content, subtext, category}) -> let post = model.post in ({model | post = {post | title = title, content = content, category = category, subtext = subtext}}, Cmd.none)
     GotCategory (Ok (title, posts)) -> ({model | errMessage = Nothing, header = title, posts = posts}, Cmd.none)
     Login -> (model, handleLogin model)
     LoginResult (Ok (Just _ as u)) -> ({model | user = u}, load "/")
@@ -189,15 +211,21 @@ update msg model =
     LogoutResult _ -> (model, load "/")
     UsernameUpdate u -> ({model | username = u}, Cmd.none)
     PasswordUpdate p -> ({model | password = p}, Cmd.none)
-    TitleUpdate t -> ({model | title = t}, Cmd.none)
+    TitleUpdate t -> let post = model.post in ({model | post = {post | title = t}}, Cmd.none)
-    SubtextUpdate s -> ({model | subtext = s}, Cmd.none)
+    SubtextUpdate s -> let post = model.post in ({model | post = {post | subtext = s}}, Cmd.none)
-    ContentUpdate c -> ({model | content = c}, Cmd.none)
+    ContentUpdate c -> let post = model.post in ({model | post = {post | content = c}}, Cmd.none)
-    CategoryUpdate c -> ({model | category = c}, Cmd.none)
+    CategoryUpdate c -> let post = model.post in let category = model.post.category in ({model | post = {post | category = {category | name = c}}}, Cmd.none)
     CreatePost -> (model, handleCreatePost model)
     CreatePostResult (Ok (Just postid)) -> (model, load ("/post/" ++ postid))
     CreatePostResult (Ok Nothing) -> ({model | errMessage = Just "Failed to create post"}, Cmd.none)
+    DeletePostResult (Ok True) -> (model, load "/")
+    DeletePostResult (Ok False) -> ({model | errMessage = Just "Failed to delete post"}, Cmd.none)
     GotWhoami (Ok (Just u)) -> ({model | user = Just (User u)}, messageOfRoute model.route)
     GotWhoami _ -> (model, messageOfRoute model.route)
+    GotoEditPost -> ({model | route = Just EditPostView}, Cmd.none)
+    EditPost -> (model, handleEditPost model)
+    EditPostResult (Ok (Just postid)) -> (model, load ("/post/" ++ postid))
+    DeletePost -> (model, handleDeletePost model)
     _ -> ({model | errMessage = Just "Something has gone horribly wrong."}, Cmd.none)
 
 handleLogin : Model -> Cmd Msg
@@ -217,14 +245,46 @@ handleCreatePost model =
         url = "/v1/createPost",
         body = multipartBody [
           stringPart "username" user.username,
-          stringPart "title" model.title,
+          stringPart "title" model.post.title,
-          stringPart "subtext" model.subtext,
+          stringPart "subtext" model.post.subtext,
-          stringPart "content" model.content,
+          stringPart "content" model.post.content,
-          stringPart "category" model.category
+          stringPart "category" model.post.category.name
         ],
         expect = Http.expectJson CreatePostResult processCreatePost
       }
 
+handleEditPost : Model -> Cmd Msg
+handleEditPost model =
+  case model.user of 
+    Nothing -> Cmd.none
+    Just user ->
+      Http.post {
+        url = "/v1/editPost",
+        body = multipartBody [
+          stringPart "username" user.username,
+          stringPart "id" model.post.id,
+          stringPart "title" model.post.title,
+          stringPart "subtext" model.post.subtext,
+          stringPart "content" model.post.content,
+          stringPart "category" model.post.category.name
+        ],
+        expect = Http.expectJson EditPostResult processEditPost
+      }
+
+handleDeletePost : Model -> Cmd Msg
+handleDeletePost model =
+  case model.user of 
+    Nothing -> Cmd.none
+    Just user ->
+      Http.post {
+        url = "/v1/deletePost",
+        body = multipartBody [
+          stringPart "username" user.username,
+          stringPart "id" model.post.id
+        ],
+        expect = Http.expectJson DeletePostResult processDeletePost
+      }
+
 type alias Document msg = {
   title: String,
   body: List (Html msg)
@@ -263,10 +323,13 @@ renderModel model =
       case model.route of
         Just route -> case route of
           Home -> div [] [h1 [] [text "Welcome to my blog."],cardListing model]
-          PostView _ -> div [] [h1 [] [text (model.header)], p [] [text(model.body)], h3 [] [text(model.footer ++ " ")]]
+          PostView _ -> div [] ([h1 [] [text (model.post.title)], p [] [text(model.post.content)], h3 [] [text(model.post.category.name ++ " ")]] ++ case model.user of
+            Nothing -> []
+            Just u -> [a [href "", onClick DeletePost] [text "Delete Post"], text " - ", a [href "", onClick GotoEditPost] [text "Edit Post"]])
           CategoryView _ -> div [] [h1 [] [text (model.header)], cardListing model]
           LoginView -> loginForm model
-          CreatePostView -> createPostForm model
+          CreatePostView -> createPostForm model CreatePost "Create Post"
+          EditPostView -> createPostForm model EditPost "Edit Post"
           _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ]
         _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ]
 cardListing : Model -> Html Msg
@@ -327,17 +390,17 @@ renderPost post =
       ]
   ]
 
-createPostForm : Model -> Html Msg
+createPostForm : Model -> Msg -> String -> Html Msg
-createPostForm model =
+createPostForm model msg buttonText =
   div [
     style "display" "flex",
     style "flex-direction" "column"
   ] [
-    viewInput "text" "title" "Title" model.title TitleUpdate,
+    viewInput "text" "title" "Title" model.post.title TitleUpdate,
-    viewInput "text" "subtext" "Subtext" model.subtext SubtextUpdate,
+    viewInput "text" "subtext" "Subtext" model.post.subtext SubtextUpdate,
-    viewTextarea "content" "Content" model.content ContentUpdate,
+    viewTextarea "content" "Content" model.post.content ContentUpdate,
-    viewInput "text" "category" "Subtext" model.category CategoryUpdate,
+    viewInput "text" "category" "Blog Post" model.post.category.name CategoryUpdate,
-    button [onClick CreatePost] [text "Create Post"]
+    button [onClick msg] [text buttonText]
   ]
 
 loginForm : Model -> Html Msg