diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 601fb0d..d89a02d 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -142,7 +142,7 @@ handleLogin c = do loginSuccess <- lift $ attemptLogin c username password case loginSuccess of Just authtoken -> do - addCookie Session (mkCookie "token" authtoken) + addCookie (MaxAge 604800) (mkCookie "token" authtoken) ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("username", toJSString username)] Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("username", toJSString "")] @@ -155,24 +155,45 @@ validateCookie c a u = do (at:[]):[] -> return $ (fromSql at) == (hexOfBS $ SHA256.hash $ C.pack a) _ -> return False -attemptCreatePost :: IConnection t => t -> String -> String -> String -> String -> String -> String -> IO Bool +createCategoryIfNotExist :: IConnection t => t -> String -> IO (Maybe String) +createCategoryIfNotExist c n = do + getCategory <- prepare c "SELECT * FROM categories WHERE name = ?;" + execute getCategory [toSql n] + result <- fetchAllRows getCategory + + case result of + [cid:name:[]] -> return $ fromSql cid + _ -> do + createCategory <- prepare c "INSERT INTO categories(name) VALUES(?) RETURNING catid;" + execute createCategory [toSql n] + category <- fetchAllRows createCategory + commit c + + case category of + [cid:[]] -> return $ Just $ fromSql cid + _ -> return Nothing + + +attemptCreatePost :: IConnection t => t -> String -> String -> String -> String -> String -> String -> IO (Maybe String) attemptCreatePost c authtoken username title subtext content category = do cookieValid <- validateCookie c authtoken username case cookieValid of - False -> return False + False -> return Nothing True -> do -- First we should probably validate that the category actually exists - getCategory <- prepare c "SELECT * FROM categories WHERE catid = ?;" - execute getCategory [toSql category] - result <- fetchAllRows getCategory + result <- createCategoryIfNotExist c category case result of - [] -> do return False - _ -> do + 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(?, ?, ?, ?);" - execute addPost [toSql category, toSql title, toSql subtext, toSql content] + 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 commit c - return True + + case post of + [pid:[]] -> return $ Just $ fromSql pid + _ -> return Nothing handleCreatePost :: IConnection t => t -> ServerPart Response handleCreatePost c = do @@ -186,8 +207,27 @@ handleCreatePost c = do success <- lift $ attemptCreatePost c authtoken username title subtext content category case success of - True -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true")] - False -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false")] + Just pid -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("postid", toJSString pid)] + Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("postid", toJSString "")] + +attemptWhoami :: IConnection t => t -> String -> IO (Maybe String) +attemptWhoami c at = do + getUser <- prepare c "SELECT username FROM users WHERE authtoken = ?;" + let atHash = hexOfBS $ SHA256.hash $ C.pack at + execute getUser [toSql atHash] + result <- fetchAllRows getUser + + case result of + [u:[]] -> return $ Just $ fromSql u + _ -> return $ Nothing + +handleWhoami :: IConnection t => t -> ServerPart Response +handleWhoami c = do + authtoken <- lookCookieValue "token" + whoami <- lift $ attemptWhoami c authtoken + case whoami of + Just u -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("username", toJSString u)] + Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("username", toJSString "")] main :: IO () main = do @@ -209,5 +249,6 @@ main = do , dir "v1" $ dir "categories" $ require (getCategoryListing c 0) $ \cats -> ok $ toResponse cats , dir "v1" $ dir "login" $ handleLogin c , dir "v1" $ dir "createPost" $ handleCreatePost c + , dir "v1" $ dir "whoami" $ handleWhoami c , notFound $ toResponse "Endpoint does not exist" ] diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 175c836..53b1dd7 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -82,11 +82,17 @@ processLogin = "true" -> Just (User b) _ -> Nothing) (field "success" string) (field "username" string) -processCreatePost : Decoder Bool +processCreatePost : Decoder (Maybe String) processCreatePost = - Json.Decode.map (\a -> case a of - "true" -> True - _ -> False) (field "success" string) + 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 + "true" -> Just b + _ -> Nothing) (field "success" string) (field "username" string) messageOfRoute : Maybe Route -> Cmd Msg messageOfRoute r = @@ -137,7 +143,8 @@ type Msg | SubtextUpdate String | CategoryUpdate String | CreatePost - | CreatePostResult (Result Http.Error Bool) + | CreatePostResult (Result Http.Error (Maybe String)) + | GotWhoami (Result Http.Error (Maybe String)) init : () -> Url.Url -> Browser.Navigation.Key -> (Model, Cmd Msg) init _ url key = @@ -146,9 +153,9 @@ init _ url key = header = "", body = "", footer = "", pinnedPosts = [], posts = [], route = r, key = key, errMessage = Nothing, username = "", password = "", user = Nothing, - title = "", subtext = "", content = "", category = "1" + title = "", subtext = "", content = "", category = "Blog Post" }, - messageOfRoute r + Http.get {url = "/v1/whoami", expect = Http.expectJson GotWhoami processWhoami} ) update : Msg -> Model -> (Model, Cmd Msg) @@ -177,8 +184,10 @@ update msg model = ContentUpdate c -> ({model | content = c}, Cmd.none) CategoryUpdate c -> ({model | category = c}, Cmd.none) CreatePost -> (model, handleCreatePost model) - CreatePostResult (Ok True) -> (model, Cmd.none) - CreatePostResult (Ok False) -> ({model | errMessage = Just "Failed to create post"}, Cmd.none) + CreatePostResult (Ok (Just postid)) -> (model, load ("/post/" ++ postid)) + CreatePostResult (Ok Nothing) -> ({model | errMessage = Just "Failed to create post"}, Cmd.none) + GotWhoami (Ok (Just u)) -> ({model | user = Just (User u)}, messageOfRoute model.route) + GotWhoami (Ok Nothing) -> (model, messageOfRoute model.route) _ -> ({model | errMessage = Just "Something has gone horribly wrong."}, Cmd.none) handleLogin : Model -> Cmd Msg @@ -317,6 +326,7 @@ createPostForm model = 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"] ]