General improvements

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 = ?;"
+      result <- createCategoryIfNotExist c category
-      execute getCategory [toSql category]
-      result <- fetchAllRows getCategory
       case result of
-        [] -> do return False
+        Nothing -> do return Nothing
-        _ -> do
+        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(?, ?, ?, ?);"
+          addPost <- prepare c "INSERT INTO posts(catid, title, subtext, content) VALUES(?, ?, ?, ?) RETURNING postid;"
-          execute addPost [toSql category, toSql title, toSql subtext, toSql content]
+          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")]
+    Just pid -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("postid", toJSString pid)]
-    False -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false")]
+    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"
          ]

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 
+  map2 (\a->\b->case a of 
-    "true" -> True
+    "true" -> Just b
-    _ -> False) (field "success" string)
+    _ -> 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 (Just postid)) -> (model, load ("/post/" ++ postid))
-    CreatePostResult (Ok False) -> ({model | errMessage = Just "Failed to create post"}, Cmd.none) 
+    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"]
   ]