General improvements
This commit is contained in:
parent
5312be326e
commit
edf8986ec1
GPG Key ID:
45AC398F44F0DAFE
@ -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"
|
||||
]
|
||||
|
||||
@ -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"]
|
||||
]
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user