Commit 0ee09cbc authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

registration and user page.

parent 5cf33497
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: ced41b3374414543c4a0650f1d8a2b28e8dbe85fb8ab214e656b05de00f0fe88
-- hash: 01d9b30cb49341b29189cabdcccfe7d240125e2be98744aac73ca82059e08a55
name: Cirkeltrek
version: 0.0.0
......@@ -14,22 +14,25 @@ library
Application
DBOp.CRUDCategory
DBOp.CRUDForum
DBOp.CRUDGroup
DBOp.CRUDPost
DBOp.CRUDTopic
DBOp.CRUDUser
Flux.AdmCategory
Flux.AdmForum
Flux.Forum
Flux.Home
Flux.Post
Flux.Topic
Flux.User
Foundation
Handler.Adm.Category
Handler.Adm.Forum
Handler.Forum
Handler.Home
Handler.Post
Handler.Profile
Handler.Topic
Handler.User
Import
Import.NoFoundation
Import.Util
......
......@@ -26,7 +26,7 @@ import Settings (ApplicationSettings (..),
configSettingsYmlValue)
import Handler.Home
import Handler.Profile
import Handler.User
import Handler.Adm.Category
import Handler.Adm.Forum
import Handler.Forum
......
......@@ -104,3 +104,8 @@ updateForumIncrementReplyAndLasts fid username pid last = do
, ForumsLastPost =. (val $ Just last)
]
where_ (forum ^. ForumsId ==. val fid)
updateForumIncrementTopic fid = do
update $ \forum -> do
set forum [ForumsTopicsCount +=. (val 1)]
where_ (forum ^. ForumsId ==. val fid)
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module DBOp.CRUDGroup where
import Import hiding (Value, groupBy, on,
update, (+=.), (=.), (==.))
import Database.Esqueleto
selectGroupByGrouping groupname = do
select $
from $ \group -> do
where_ (group ^. GroupsGrouping ==. val groupname)
limit 1
return group
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module DBOp.CRUDUser where
import Import hiding (Value, groupBy, on, update, (+=.),
(=.), (==.), (||.))
import Database.Esqueleto
insertUser ::
(BaseBackend backend ~ SqlBackend, PersistStoreWrite backend, MonadIO m)
=> Key Groups
-> Text
-> Maybe Text
-> Text
-> UTCTime
-> ReaderT backend m (Key Users)
insertUser usersGroupId usersUsername usersPassword usersEmail usersJoinTime = do
let usersRepliesPosted = 0
usersTopicsStarted = 0
insert $ Users {..}
selectUserById ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Users
-> ReaderT backend m [Entity Users]
selectUserById uid = do
select $
from $ \user -> do
where_ (user ^. UsersId ==. val uid)
limit 1
return user
selectUserByUsernameOrEmail ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> ReaderT backend m [Entity Users]
selectUserByUsernameOrEmail username email = do
select $
from $ \user -> do
where_
(user ^. UsersUsername ==. val username ||. user ^. UsersEmail ==.
val email)
limit 1
return user
......@@ -44,8 +44,7 @@ getTopicsInForum fid page | page < 1 = invalidArgs ["Yo! Have you seen negative
getTopicsInForum fid page = liftHandler $ runDB $ selectTopicsByForumIdPage fid page
createTopicByPosting ::
( BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, PersistStoreWrite (YesodPersistBackend (HandlerSite m))
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, MonadHandler m
)
......@@ -58,7 +57,9 @@ createTopicByPosting ::
createTopicByPosting fid userid username subject content = do
now <- liftIO getCurrentTime
tid <- liftHandler $ runDB $ insertTopic fid username subject
pid <- liftHandler $ runDB $ insertPost tid 1 username userid content
liftHandler $ runDB $ do
_ <- insertPost tid 1 username userid content
updateForumIncrementTopic fid
return tid
lockUnlockTopic ::
......
......@@ -28,9 +28,9 @@ getCategoriesForIndex ::
, Maybe Text)])]
getCategoriesForIndex = do
categoriesandforums <- liftHandler $ runDB $ selectCategoriesForIndex
return $ map anu categoriesandforums
return $ map catNZip8 categoriesandforums
where
anu s =
catNZip8 s =
case s of
(a, Just b, Just c, Just d, Just e, Just f, Just g, Just h, Just i) ->
(a, zip8 b c d e f g h i)
......
......@@ -12,7 +12,7 @@ import DBOp.CRUDForum
import DBOp.CRUDPost
import DBOp.CRUDTopic
import Handler.Profile
import Handler.User
getTopicById ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.User where
import Import
import Yesod.Auth.Util.PasswordStore
import DBOp.CRUDGroup
import DBOp.CRUDUser
unusedUser ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Text
-> Text
-> m ()
unusedUser username email = do
users <- liftHandler $ runDB $ selectUserByUsernameOrEmail username email
case users of
[] -> return ()
_ -> invalidArgs ["Username and/or email has been used."]
getUserById ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Users
-> m (Entity Users)
getUserById uid = do
users <- liftHandler $ runDB $ selectUserById uid
case users of
[] -> notFound
x:_ -> return x
registerUser ::
( BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, PersistStoreWrite (YesodPersistBackend (HandlerSite m))
, MonadHandler m
, YesodPersist (HandlerSite m)
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
)
=> Text
-> Text
-> Text
-> m (Key Users)
registerUser username password email = do
unusedUser username email
now <- liftIO getCurrentTime
gids <- liftHandler $ runDB $ selectGroupByGrouping Member
case gids of
[] -> invalidArgs ["Call the Administrator"]
x:_ -> do
password' <- liftIO $ makePassword (encodeUtf8 password) 17
liftHandler $
runDB $
insertUser
(entityKey x)
username
(Just $ decodeUtf8 password')
email
now
......@@ -36,7 +36,9 @@ mkYesodData
/ HomeR GET
/static StaticR Static appStatic
/auth SigninR Auth getAuth
/register RegisterR GET POST
/profile ProfileR GET
/user/#Int64 UserR GET
/admin/category AdmCategoryR GET POST
/admin/forum AdmForumR GET POST
/forum/#Int64 ForumR GET POST
......@@ -84,6 +86,7 @@ instance Yesod App where
authRoute _ = Just $ SigninR LoginR
isAuthorized (SigninR _) _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized RegisterR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
isAuthorized _ _ = isLoggedIn
......@@ -94,6 +97,13 @@ isLoggedIn = do
Nothing -> return $ Unauthorized "login please"
Just _ -> return Authorized
isNotLoggedIn :: Handler ()
isNotLoggedIn = do
maut <- maybeAuth
case maut of
Nothing -> return ()
Just _ -> redirect $ HomeR
getUserAndGrouping :: Handler (Maybe (Key Users, Text, Grouping))
getUserAndGrouping = do
maut <- maybeAuth
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Handler.Profile where
import Import
import Database.Persist.Sql
getProfileR :: Handler Html
getProfileR = do
(Just (Entity userid user)) <- maybeAuth
defaultLayout $ do
setTitle "Nice"
[whamlet|
<p> You are: #{usersUsername user}
<p> Userid: #{fromSqlKey userid}
<p> Your email: #{usersEmail user}
|]
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.User where
import Import
import Data.Time.LocalTime
import Database.Persist.Sql
import Flux.User
data RegisterForm = RegisterForm
{ registerFormUsername :: Text
, registerFormPassword :: Text
, registerFormEmail :: Text
} deriving (Show)
registerForm :: Form RegisterForm
registerForm =
renderDivs $ RegisterForm
<$> areq textField "Username" Nothing
<*> areq passwordField "Password" Nothing
<*> areq emailField "Email" Nothing
getRegisterR :: Handler Html
getRegisterR = do
isNotLoggedIn
(wid, enct) <- generateFormPost registerForm
defaultLayout $(widgetFile "register")
postRegisterR :: Handler Html
postRegisterR = do
isNotLoggedIn
((res, wid), enct) <- runFormPost registerForm
case res of
FormSuccess r -> do
_ <-
registerUser
(registerFormUsername r)
(registerFormPassword r)
(registerFormEmail r)
redirect HomeR
_ ->
invalidArgs
[ "Your input doesn't contribute sufficiently"
, " for this capitalistic society. Think about it."
]
getProfileR :: Handler Html
getProfileR = do
(Just (Entity userid user)) <- maybeAuth
defaultLayout $ do
setTitle "Nice"
[whamlet|
<p> You are: #{usersUsername user}
<p> Userid: #{fromSqlKey userid}
<p> Your email: #{usersEmail user}
|]
getUserR :: Int64 -> Handler Html
getUserR uid = do
(ruid, name, group) <- allowedToPost
(Entity uid' user ) <- getUserById $ toSqlKey uid
defaultLayout $(widgetFile "profile")
......@@ -11,6 +11,8 @@
<li .navigation-item>
<a .navigation-link [email protected]{SigninR LogoutR}> Logout
$nothing
<li .navigation-item>
<a .navigation-link [email protected]{RegisterR}> Register
<li .navigation-item>
<a .navigation-link [email protected]{SigninR LoginR}> Login
<section .container>
......
<.container>
<.row>
<.column>
<.column.column-50>
<form [email protected]{action} method=post>
<fieldset>
<label for=username-field> Username
<input #username-field name=username placeholder="Your Username." type=text>
<label for=password-field> Password
<input #password-field name=password placeholder="Your Password." type=password>
<form [email protected]{action} method=post>
<fieldset>
<label for=username-field> Username
<input #username-field name=username placeholder="Your Username." type=text>
<label for=password-field> Password
<input #password-field name=password placeholder="Your Password." type=password>
<input .button-primary value=sign-in type=submit>
<.column>
\ No newline at end of file
<input .button-primary value=sign-in type=submit>
\ No newline at end of file
<.row>
<.column>
<p> Username:
<.column.column-75>
<p> #{usersUsername user}
<.row>
<.column>
<p> Email:
<.column.column-75>
<p> #{usersEmail user}
<.row>
<.column>
<p> Join Date:
<.column.column-75>
<p> #{show $ utcToLocalTime timeZone $ usersJoinTime user}
<.row>
<.column>
<p> Topics Started:
<.column.column-75>
<p> #{usersTopicsStarted user}
<.row>
<.column>
<p> Replies Posted:
<.column.column-75>
<p> #{usersRepliesPosted user}
<form [email protected]{RegisterR} method=post enctype=#{enct}>
^{wid}
<input .button-primary name=register value=register type=submit>
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment