diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 3c07061..525f03a 100644 --- a/backend/app/Main.hs +++ b/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" ] diff --git a/docker-compose.yml b/docker-compose.yml index 7dea561..d40387a 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -18,7 +18,6 @@ services: database: image: postgres - restart: unless-stopped environment: - POSTGRES_PASSWORD=root - POSTGRES_USER=blog \ No newline at end of file diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index c898088..7eaac06 100644 --- a/frontend/src/Main.elm +++ b/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, - subtext: String, - content: String, - category: String + post: Post } 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) - SubtextUpdate s -> ({model | subtext = s}, Cmd.none) - ContentUpdate c -> ({model | content = c}, Cmd.none) - CategoryUpdate c -> ({model | category = c}, Cmd.none) + TitleUpdate t -> let post = model.post in ({model | post = {post | title = t}}, Cmd.none) + SubtextUpdate s -> let post = model.post in ({model | post = {post | subtext = s}}, Cmd.none) + ContentUpdate c -> let post = model.post in ({model | post = {post | content = 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 "subtext" model.subtext, - stringPart "content" model.content, - stringPart "category" model.category + stringPart "title" model.post.title, + stringPart "subtext" model.post.subtext, + stringPart "content" model.post.content, + 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 = +createPostForm : Model -> Msg -> String -> Html Msg +createPostForm model msg buttonText = div [ style "display" "flex", style "flex-direction" "column" ] [ - viewInput "text" "title" "Title" model.title TitleUpdate, - viewInput "text" "subtext" "Subtext" model.subtext SubtextUpdate, - viewTextarea "content" "Content" model.content ContentUpdate, - viewInput "text" "category" "Subtext" model.category CategoryUpdate, - button [onClick CreatePost] [text "Create Post"] + viewInput "text" "title" "Title" model.post.title TitleUpdate, + viewInput "text" "subtext" "Subtext" model.post.subtext SubtextUpdate, + viewTextarea "content" "Content" model.post.content ContentUpdate, + viewInput "text" "category" "Blog Post" model.post.category.name CategoryUpdate, + button [onClick msg] [text buttonText] ] loginForm : Model -> Html Msg