Added ability to log in. Added post creation
This commit is contained in:
parent
d52c401206
commit
5312be326e
GPG Key ID:
45AC398F44F0DAFE
@ -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"
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ] []
|
||||
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 ] []
|
||||
Loading…
x
Reference in New Issue
Block a user