Commit d83b2a0d authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

administer user. prep. search and display.

parent 42344b7d
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 79d1f04a49c5644f4f9793d1ced51e6072187e4c6a949b5859fc10a4915fa81a
-- hash: be478473889e1800099c7765403b2d8cd40e42891190aaa39a9ddd3be71daf73
name: Cirkeltrek
version: 0.0.0
......@@ -24,6 +24,7 @@ library
Flux.Adm.Forum
Flux.Forum
Flux.Home
Flux.Miscellaneous
Flux.Post
Flux.Topic
Flux.User
......@@ -32,6 +33,7 @@ library
Handler.Adm.Ban
Handler.Adm.Category
Handler.Adm.Forum
Handler.Adm.User
Handler.Forum
Handler.Home
Handler.Post
......
......@@ -31,6 +31,7 @@ import Handler.Adm
import Handler.Adm.Category
import Handler.Adm.Forum
import Handler.Adm.Ban
import Handler.Adm.User
import Handler.Forum
import Handler.Topic
import Handler.Post
......
......@@ -43,3 +43,16 @@ selectGroupByUsername username = do
&&. user ^. UsersUsername ==. val username)
limit 1
return (user ^. UsersId, group ^. GroupsId, group ^. GroupsGrouping)
selectAllGroups ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> ReaderT backend m [Entity Groups]
selectAllGroups = do
select $
from $ \group -> do
orderBy [asc (group ^. GroupsGrouping)]
return group
......@@ -67,3 +67,17 @@ updateUserGroupingByUsername username grouping = do
update $ \user -> do
set user [UsersGroupId =. val (entityKey x)]
where_ (user ^. UsersUsername ==. val username)
selectUsersByConditions mgid musername memail = do
select $
from $ \(user, group) -> do
where_
( qbuilder user UsersGroupId mgid
&&. qbuilder user UsersUsername musername
&&. qbuilder user UsersEmail memail
&&. user ^. UsersGroupId ==. group ^. GroupsId)
orderBy [asc (user ^. UsersUsername)]
return (user, group ^. GroupsGrouping)
where
qbuilder _ _ Nothing = (val True)
qbuilder user accessor (Just v) = (user ^. accessor ==. val v)
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.Miscellaneous where
import Import
import DBOp.CRUDGroup
getAllGroups ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> m [Entity Groups]
getAllGroups = liftHandler $ runDB $ selectAllGroups
......@@ -7,6 +7,7 @@ module Flux.User where
import Import
import Database.Esqueleto
import Yesod.Auth.Util.PasswordStore
import DBOp.CRUDGroup
......@@ -26,7 +27,7 @@ unusedUser username email = do
users <- liftHandler $ runDB $ selectUserByUsernameOrEmail username email
case users of
[] -> return ()
_ -> invalidArgs ["Username and/or email has been used."]
_ -> invalidArgs ["Username and/or email has been used."]
getUserById ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
......@@ -40,7 +41,7 @@ getUserById ::
getUserById uid = do
users <- liftHandler $ runDB $ selectUserById uid
case users of
[] -> notFound
[] -> notFound
x:_ -> return x
registerUser ::
......@@ -72,3 +73,8 @@ registerUser username password email = do
(Just $ decodeUtf8 password')
email
now
getUsersByConditions mgid musername memail = do
userandgroup <-
liftHandler $ runDB $ selectUsersByConditions mgid musername memail
return $ map (\(user, Value group) -> (user, group)) userandgroup
......@@ -44,6 +44,7 @@ mkYesodData
/admin/forum AdmForumR GET POST
/admin/ban AdmBanR GET POST
/admin/ban/options AdmBanOptionsR POST
/admin/user AdmUserR GET POST
/forum/#Int64 ForumR GET POST
/forum/#Int64/#Int64 ForumPageR GET
/topic/#Int64 TopicR GET POST
......@@ -190,6 +191,8 @@ adminRouteToText AdmBanR = "Manage Ban"
adminRouteToText AdmBanOptionsR = "Ban Options"
adminRouteToText AdmCategoryR = "Manage Categories"
adminRouteToText AdmForumR = "Manage Forums"
adminRouteToText AdmUserR = "Manage User"
adminRouteToText _ = "Fix Me"
profileLayout ::
Key Users -> Text -> Grouping -> Entity Users -> Widget -> Handler Html
......@@ -208,4 +211,6 @@ allowedToEditProfile uid group profileid =
profileid == uid || group == Administrator || group == Moderator
profileRouteToText :: Route App -> Text
profileRouteToText ProfileR = "Common Information"
profileRouteToText ProfileR = "Common Information"
profileRouteToText (UserR _) = "Common Information of user"
profileRouteToText _ = "Not Needed"
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Adm.User where
import Import
import Database.Esqueleto
import Flux.Miscellaneous
import Flux.User
data SearchUserForm = SearchUserForm
{ searchUserFormGroupId :: Maybe Int64
, searchUserFormUsername :: Maybe Text
, searchUserFormEmail :: Maybe Text
}
groupToHtml :: Grouping -> Html
groupToHtml = toHtml . show
searchUserForm :: [Entity Groups] -> Form SearchUserForm
searchUserForm groups =
renderDivs $ SearchUserForm
<$> aopt (selectFieldList glist) "Groups" Nothing
<*> aopt textField "Username" Nothing
<*> aopt textField "Email" Nothing
where
glist :: [(Text, Int64)]
glist =
map
(\x ->
( pack . show . groupsGrouping $ entityVal x
, fromSqlKey . entityKey $ x))
groups
getAdmUserR :: Handler Html
getAdmUserR = do
(uid, name, group) <- allowedToMod
groups <- getAllGroups
(wid, enct) <- generateFormPost $ searchUserForm groups
let users = []
adminLayout uid name group $ do
setTitle "Manage Users"
$(widgetFile "adm-user")
postAdmUserR :: Handler Html
postAdmUserR = do
(uid, name, group) <- allowedToMod
groups <- getAllGroups
((res, wid), enct) <- runFormPost $ searchUserForm groups
let (mgid, musername, memail) =
case res of
FormSuccess r ->
( toSqlKey <$> searchUserFormGroupId r
, searchUserFormUsername r
, searchUserFormEmail r)
_ -> (Nothing, Nothing, Nothing)
users <- getUsersByConditions mgid musername memail
adminLayout uid name group $ do
setTitle "Users"
$(widgetFile "adm-user")
......@@ -50,9 +50,8 @@ postRegisterR = do
getProfileR :: Handler Html
getProfileR = do
(ruid, name, group) <- allowedToPost
user'@(Entity uid' user) <- getUserById ruid
profileLayout ruid name group user' $(widgetFile "profile-info")
(uid, _, _) <- allowedToPost
redirect $ UserR $ fromSqlKey uid
getUserR :: Int64 -> Handler Html
getUserR uid = do
......
<h4> Search User
<form [email protected]{AdmUserR} method=post enctype=#{enct}>
^{wid}
<input .button name=search value=search type=submit>
<h4> Result
<form action="#" method=post enctype=#{enct}>
<table>
<thead>
<th> Username
<th> Email
<th> Status
<th> Posts
<th> Actions
<th> Select
<tbody>
$forall (user, g) <- users
<tr>
<td>
<a [email protected]{UserR $ fromSqlKey $ entityKey user}> #{usersUsername $ entityVal user}
<td> #{usersEmail $ entityVal user}
<td> #{groupToHtml g}
<td> #{usersRepliesPosted $ entityVal user}
<td>
<a href="#"> Show posts
<td>
<input name=user-id value=#{fromSqlKey $ entityKey user} type=checkbox>
$case group
$of Administrator
<input .button name=promote value=ban type=submit>
<input .button name=promote value=change type=submit>
$of Moderator
<input .button name=promote value=ban type=submit>
$of _
......@@ -29,7 +29,7 @@
<tr>
<td> <a [email protected]{AdmR}> Index
<tr>
<td> <a href="#"}> Users
<td> <a href=@{AdmUserR}> Users
<tr>
<td> <a [email protected]{AdmBanR}> Bans
<tr>
......
......@@ -8,7 +8,7 @@
$of Administrator
<li .navigation-item>
<a .navigation-link [email protected]{AdmR}> Administration
$of Administrator
$of Moderator
<li .navigation-item>
<a .navigation-link [email protected]{AdmR}> Administration
$of Member
......
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