From 5312be326e4a4fafea3377ca44738059420a6afa Mon Sep 17 00:00:00 2001 From: Xnoe Date: Fri, 20 May 2022 23:15:41 +0100 Subject: [PATCH] Added ability to log in. Added post creation --- backend/app/Main.hs | 98 +++++++++++++++++++++++++++++++++++++- backend/backend.cabal | 2 +- frontend/src/Main.elm | 106 +++++++++++++++++++++++++++++++++++------- 3 files changed, 186 insertions(+), 20 deletions(-) diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 3eb6a54..601fb0d 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -2,12 +2,18 @@ module Main where import Happstack.Server import Control.Monad +import Control.Monad.Trans import Control.Exception import Database.HDBC import Database.HDBC.PostgreSQL (connectPostgreSQL) import Text.JSON import Data.ByteString.Char8 as C (pack) import Data.ByteString.Lazy.Char8 as L (pack) +import Data.ByteString as B (unpack, ByteString) +import Text.Printf +import System.Random (newStdGen, randomRs) + +import Crypto.Hash.SHA256 as SHA256 instance ToMessage JSValue where toContentType _ = C.pack "application/json" @@ -98,20 +104,110 @@ getPostContent c pid = do return $ Just $ showJSON $ toJSObject [title, content, cat, catid]; _ -> fail "Post does not exist!" +hexOfBS :: B.ByteString -> String +hexOfBS = concatMap (printf "%02x") . B.unpack + +random256 :: IO String +random256 = do + g <- newStdGen + return $ take 256 (randomRs ('a', 'z') g) + +attemptLogin :: IConnection t => t -> String -> String -> IO (Maybe String) +attemptLogin c user pass = do + getRows <- prepare c "SELECT * FROM users WHERE username = ?" + execute getRows [toSql user] + result <- fetchAllRows getRows + + case result of + (userid:username:password:authtoken:[]):[] -> do + let passwordHashBS = SHA256.hash (C.pack pass) + let passwordHash = hexOfBS passwordHashBS + if passwordHash == (fromSql password) then do + at <- random256 + let atHashBS = SHA256.hash (C.pack at) + let atHash = hexOfBS atHashBS + updateAuthToken <- prepare c "UPDATE users SET authtoken = ? WHERE userid = ?" + execute updateAuthToken [toSql atHash, toSql userid] + commit c + return $ Just at + else + return Nothing + _ -> return Nothing + +handleLogin :: IConnection t => t -> ServerPart Response +handleLogin c = do + methodM POST + username <- look "username" + password <- look "password" + loginSuccess <- lift $ attemptLogin c username password + case loginSuccess of + Just authtoken -> do + addCookie Session (mkCookie "token" authtoken) + ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("username", toJSString username)] + Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("username", toJSString "")] + +validateCookie :: IConnection t => t -> String -> String -> IO Bool +validateCookie c a u = do + getAuthToken <- prepare c "SELECT authtoken from users WHERE username = ?;" + execute getAuthToken [toSql u] + result <- fetchAllRows getAuthToken + case result of + (at:[]):[] -> return $ (fromSql at) == (hexOfBS $ SHA256.hash $ C.pack a) + _ -> return False + +attemptCreatePost :: IConnection t => t -> String -> String -> String -> String -> String -> String -> IO Bool +attemptCreatePost c authtoken username title subtext content category = do + cookieValid <- validateCookie c authtoken username + case cookieValid of + False -> return False + 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 + case result of + [] -> do return False + _ -> 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] + commit c + return True + +handleCreatePost :: IConnection t => t -> ServerPart Response +handleCreatePost c = do + methodM POST + authtoken <- lookCookieValue "token" + username <- look "username" + title <- look "title" + subtext <- look "subtext" + content <- look "content" + category <- look "category" + + 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")] + main :: IO () main = do c <- connectPostgreSQL "host=database user=blog password=root dbname=blog" createPostsTable <- prepare c "CREATE TABLE IF NOT EXISTS posts(postid serial primary key, catid int, title varchar(128), subtext varchar(128), content text);" createCategoriesTable <- prepare c "CREATE TABLE IF NOT EXISTS categories(catid serial primary key, name varchar(128));" + createUsersTable <- prepare c "CREATE TABLE IF NOT EXISTS users(userid serial primary key, username varchar(128), password varchar(128), authtoken varchar(128));" execute createPostsTable [] execute createCategoriesTable [] + execute createUsersTable [] commit c - simpleHTTP config $ + simpleHTTP config $ do + decodeBody (defaultBodyPolicy "/tmp/" 0 4096 4096) msum [ dir "v1" $ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post , dir "v1" $ dir "category" $ path $ \cid -> require (getPostsInCategory c cid 0) $ \cat -> ok $ toResponse cat , dir "v1" $ dir "posts" $ require (getPostListing c 0) $ \posts -> ok $ toResponse posts , dir "v1" $ dir "categories" $ require (getCategoryListing c 0) $ \cats -> ok $ toResponse cats + , dir "v1" $ dir "login" $ handleLogin c + , dir "v1" $ dir "createPost" $ handleCreatePost c , notFound $ toResponse "Endpoint does not exist" ] diff --git a/backend/backend.cabal b/backend/backend.cabal index 242397c..e8cdc8a 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -29,6 +29,6 @@ executable backend -- LANGUAGE extensions used by modules in this package. -- other-extensions: - build-depends: base ^>=4.14.3.0, happstack-server ^>=7.7.2, HDBC ^>= 2.4.0.4, HDBC-postgresql ^>= 2.3.2.4, json ^>= 0.10, bytestring ^>= 0.10.12.0 + build-depends: base ^>=4.14.3.0, happstack-server ^>=7.7.2, HDBC ^>= 2.4.0.4, HDBC-postgresql ^>= 2.3.2.4, json ^>= 0.10, bytestring ^>= 0.10.12.0, cryptohash-sha256 ^>= 0.11.102.1, random ^>= 1.1, mtl ^>= 2.2.2 hs-source-dirs: app default-language: Haskell2010 diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 8d1fadc..175c836 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -76,9 +76,18 @@ processCategory : Decoder (String, List Post) processCategory = map2 (\a -> \b -> (a,b)) (field "category" string) (field "posts" processPostListing) -processLogin : Decoder (String) +processLogin : Decoder (Maybe User) processLogin = - (field "username" string) + map2 (\a->\b->case a of + "true" -> Just (User b) + _ -> Nothing) (field "success" string) (field "username" string) + +processCreatePost : Decoder Bool +processCreatePost = + Json.Decode.map (\a -> case a of + "true" -> True + _ -> False) (field "success" string) + messageOfRoute : Maybe Route -> Cmd Msg messageOfRoute r = case r of @@ -96,7 +105,7 @@ type alias User = { } type alias Model = { header: String, - content: String, + body: String, footer: String, pinnedPosts: List Post, posts: List Post, @@ -105,7 +114,11 @@ type alias Model = { errMessage: Maybe (String), username: String, password: String, - user: Maybe User + user: Maybe User, + title: String, + subtext: String, + content: String, + category: String } type Msg @@ -115,18 +128,25 @@ type Msg | GotCategories (Result Http.Error (List Category)) | GotPost (Result Http.Error (String, String, String)) | GotCategory (Result Http.Error (String, List Post)) - | LoginResult (Result Http.Error String) - | Username String - | Password String + | LoginResult (Result Http.Error (Maybe User)) + | UsernameUpdate String + | PasswordUpdate String | Login + | TitleUpdate String + | ContentUpdate String + | SubtextUpdate String + | CategoryUpdate String + | CreatePost + | CreatePostResult (Result Http.Error Bool) init : () -> Url.Url -> Browser.Navigation.Key -> (Model, Cmd Msg) init _ url key = let r = P.parse routeParser url in ({ - header = "", content = "", footer = "", pinnedPosts = [], + header = "", body = "", footer = "", pinnedPosts = [], posts = [], route = r, key = key, errMessage = Nothing, - username = "", password = "", user = Nothing + username = "", password = "", user = Nothing, + title = "", subtext = "", content = "", category = "1" }, messageOfRoute r ) @@ -145,16 +165,46 @@ update msg model = ) 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, content = content, footer = category}, Cmd.none) + GotPost (Ok (title, content, category)) -> ({model | errMessage = Nothing, header = title, body = content, footer = category}, Cmd.none) GotCategory (Ok (title, posts)) -> ({model | errMessage = Nothing, header = title, posts = posts}, Cmd.none) - Username u -> ({model | username = u}, Cmd.none) - Password p -> ({model | password = p}, Cmd.none) Login -> (model, handleLogin model) + LoginResult (Ok (Just _ as u)) -> ({model | user = u}, Cmd.none) + LoginResult (Ok (Nothing)) -> ({model | errMessage = Just "Invalid username or password."}, Cmd.none) + 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) + CreatePost -> (model, handleCreatePost model) + CreatePostResult (Ok True) -> (model, Cmd.none) + CreatePostResult (Ok False) -> ({model | errMessage = Just "Failed to create post"}, Cmd.none) _ -> ({model | errMessage = Just "Something has gone horribly wrong."}, Cmd.none) handleLogin : Model -> Cmd Msg handleLogin model = - Http.post {url = "/v1/login", body = multipartBody [stringPart "username" model.username, stringPart "password" model.password], expect = Http.expectJson LoginResult processLogin} + Http.post { + url = "/v1/login", + body = multipartBody [stringPart "username" model.username, stringPart "password" model.password], + expect = Http.expectJson LoginResult processLogin + } + +handleCreatePost : Model -> Cmd Msg +handleCreatePost model = + case model.user of + Nothing -> Cmd.none + Just user -> + Http.post { + 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 + ], + expect = Http.expectJson CreatePostResult processCreatePost + } type alias Document msg = { title: String, @@ -194,9 +244,10 @@ 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.content)], h3 [] [text(model.footer ++ " ")]] + PostView _ -> div [] [h1 [] [text (model.header)], p [] [text(model.body)], h3 [] [text(model.footer ++ " ")]] CategoryView _ -> div [] [h1 [] [text (model.header)], cardListing model] LoginView -> loginForm model + CreatePostView -> createPostForm model _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ] _ -> h1 [] [ text ("Not found."), a [ href "/"] [text("Return home")] ] cardListing : Model -> Html Msg @@ -257,14 +308,33 @@ renderPost post = ] ] +createPostForm : Model -> Html Msg +createPostForm model = + 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, + button [onClick CreatePost] [text "Create Post"] + ] + loginForm : Model -> Html Msg loginForm model = - div [] [ - viewInput "text" "username" "Username" model.username Username, - viewInput "password" "password" "Password" model.password Password, + div [ + style "display" "flex", + style "flex-direction" "column" + ] [ + viewInput "text" "username" "Username" model.username UsernameUpdate, + viewInput "password" "password" "Password" model.password PasswordUpdate, button [onClick Login] [text "Login"] ] viewInput : String -> String -> String -> String -> (String -> msg) -> Html msg viewInput t n p v toMsg = - input [ name n, type_ t, placeholder p, value v, onInput toMsg ] [] \ No newline at end of file + input [ name n, type_ t, placeholder p, value v, onInput toMsg ] [] + +viewTextarea : String -> String -> String -> (String -> msg) -> Html msg +viewTextarea n p v toMsg = + textarea [ name n, placeholder p, value v, onInput toMsg ] [] \ No newline at end of file