Added ability to log in. Added post creation

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"
          ]

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

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)
+  | LoginResult (Result Http.Error (Maybe User))
-  | Username String
+  | UsernameUpdate String
-  | Password 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 [] [
+  div [
-    viewInput "text" "username" "Username" model.username Username,
+    style "display" "flex",
-    viewInput "password" "password" "Password" model.password Password,
+    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 ] []
+
+viewTextarea : String -> String -> String -> (String -> msg) -> Html msg
+viewTextarea n p v toMsg =
+  textarea [ name n, placeholder p, value v, onInput toMsg ] []