Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Switch to GitLab Next
Sign in / Register
Toggle navigation
Open sidebar
Ibnu Daru Aji
Cirkeltrek
Commits
092932cd
Commit
092932cd
authored
May 21, 2018
by
Ibnu Daru Aji
Browse files
user data. search.
parent
4e414cb8
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
183 additions
and
10 deletions
+183
-10
src/DBOp/CRUDUser.hs
src/DBOp/CRUDUser.hs
+64
-3
src/Flux/.#User.hs
src/Flux/.#User.hs
+1
-0
src/Flux/User.hs
src/Flux/User.hs
+20
-0
src/Foundation.hs
src/Foundation.hs
+12
-0
src/Handler/User.hs
src/Handler/User.hs
+60
-0
templates/adm.hamlet
templates/adm.hamlet
+1
-1
templates/def.hamlet
templates/def.hamlet
+3
-3
templates/profile.hamlet
templates/profile.hamlet
+3
-3
templates/user-list.hamlet
templates/user-list.hamlet
+19
-0
No files found.
src/DBOp/CRUDUser.hs
View file @
092932cd
...
...
@@ -2,6 +2,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
...
...
@@ -68,6 +69,15 @@ updateUserGroupingByUsername username grouping = do
set
user
[
UsersGroupId
=.
val
(
entityKey
x
)]
where_
(
user
^.
UsersUsername
==.
val
username
)
qbuilder
::
(
PersistField
a
,
Esqueleto
query
expr
backend
,
PersistEntity
ent
)
=>
expr
(
Entity
ent
)
->
EntityField
ent
a
->
Maybe
a
->
expr
(
Value
Bool
)
qbuilder
_
_
Nothing
=
val
True
qbuilder
ent
accessor
(
Just
v
)
=
ent
^.
accessor
==.
val
v
selectUsersByConditions
::
(
PersistUniqueRead
backend
,
PersistQueryRead
backend
...
...
@@ -88,6 +98,57 @@ selectUsersByConditions mgid musername memail = do
&&.
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
)
selectUsersBySearchConditions
::
(
PersistUniqueRead
backend
,
PersistQueryRead
backend
,
BackendCompatible
SqlBackend
backend
,
MonadIO
m
)
=>
Maybe
Text
->
Maybe
(
Key
Groups
)
->
SortBy
->
Bool
->
ReaderT
backend
m
[(
Value
Grouping
,
Entity
Users
)]
selectUsersBySearchConditions
username
groupid
orderby
ascending
=
do
select
$
from
$
\
(
user
,
group
)
->
do
where_
(
qbuilder
group
GroupsId
groupid
&&.
qbuilder
user
UsersUsername
username
&&.
user
^.
UsersGroupId
==.
group
^.
GroupsId
)
ordering
ascending
user
orderby
return
(
group
^.
GroupsGrouping
,
user
)
ordering
::
Esqueleto
query
expr
backend
=>
Bool
->
expr
(
Entity
Users
)
->
SortBy
->
query
()
ordering
b
user
Username
=
orderBy
[(
chooseAscension
b
)
(
user
^.
UsersUsername
)]
ordering
b
user
Registered
=
orderBy
[(
chooseAscension
b
)
(
user
^.
UsersJoinTime
)]
ordering
b
user
PostCount
=
orderBy
[(
chooseAscension
b
)
(
user
^.
UsersRepliesPosted
)]
chooseAscension
::
(
Esqueleto
query
expr
backend
,
PersistField
a
)
=>
Bool
->
expr
(
Value
a
)
->
expr
OrderBy
chooseAscension
True
e
=
asc
e
chooseAscension
False
e
=
desc
e
selectAllUsers
::
(
PersistUniqueRead
backend
,
PersistQueryRead
backend
,
BackendCompatible
SqlBackend
backend
,
MonadIO
m
)
=>
Bool
->
ReaderT
backend
m
[(
Value
Grouping
,
Entity
Users
)]
selectAllUsers
ascending
=
do
let
op
=
if
ascending
then
asc
else
desc
select
$
from
$
\
(
user
,
group
)
->
do
where_
(
user
^.
UsersGroupId
==.
group
^.
GroupsId
)
orderBy
[
op
(
user
^.
UsersUsername
)]
return
(
group
^.
GroupsGrouping
,
user
)
src/Flux/.#User.hs
0 → 120000
View file @
092932cd
iaji
@
melati
.
6460
:
1526569009
\ No newline at end of file
src/Flux/User.hs
View file @
092932cd
...
...
@@ -13,6 +13,8 @@ import Yesod.Auth.Util.PasswordStore
import
DBOp.CRUDGroup
import
DBOp.CRUDUser
import
Flux.Miscellaneous
unusedUser
::
(
BackendCompatible
SqlBackend
(
YesodPersistBackend
(
HandlerSite
m
))
,
PersistQueryRead
(
YesodPersistBackend
(
HandlerSite
m
))
...
...
@@ -78,3 +80,21 @@ getUsersByConditions mgid musername memail = do
userandgroup
<-
liftHandler
$
runDB
$
selectUsersByConditions
mgid
musername
memail
return
$
map
(
\
(
user
,
Value
group
)
->
(
user
,
group
))
userandgroup
getAllUsers
::
(
BackendCompatible
SqlBackend
(
YesodPersistBackend
(
HandlerSite
m
))
,
PersistQueryRead
(
YesodPersistBackend
(
HandlerSite
m
))
,
PersistUniqueRead
(
YesodPersistBackend
(
HandlerSite
m
))
,
YesodPersist
(
HandlerSite
m
)
,
MonadHandler
m
)
=>
Bool
->
m
[(
Grouping
,
Entity
Users
)]
getAllUsers
ascending
=
do
groupandusers
<-
liftHandler
$
runDB
$
selectAllUsers
ascending
return
$
map
(
\
(
Value
a
,
x
)
->
(
a
,
x
))
groupandusers
searchUserByConditions
username
groupid
orderby
ascending
=
do
groupandusers
<-
liftHandler
$
runDB
$
selectUsersBySearchConditions
username
groupid
orderby
ascending
return
$
map
(
\
(
Value
a
,
x
)
->
(
a
,
x
))
groupandusers
src/Foundation.hs
View file @
092932cd
...
...
@@ -55,6 +55,7 @@ mkYesodData
/post/#Int64 PostR GET
/post/#Int64/edit PostEditR GET POST
/post/#Int64/report PostReportR GET POST
/userlist UserListR GET POST
|]
type
Form
a
=
Html
->
MForm
(
HandlerFor
App
)
(
FormResult
a
,
Widget
)
...
...
@@ -218,3 +219,14 @@ profileRouteToText :: Route App -> Text
profileRouteToText
ProfileR
=
"Common Information"
profileRouteToText
(
UserR
_
)
=
"Common Information of user"
profileRouteToText
_
=
"Not Needed"
data
SortBy
=
Username
|
Registered
|
PostCount
deriving
(
Eq
,
Enum
,
Bounded
)
instance
Show
SortBy
where
show
Username
=
"Username"
show
Registered
=
"Registration Date"
show
PostCount
=
"Post Count"
src/Handler/User.hs
View file @
092932cd
...
...
@@ -9,6 +9,7 @@ import Import
import
Data.Time.LocalTime
import
Database.Persist.Sql
import
Flux.Miscellaneous
import
Flux.User
data
RegisterForm
=
RegisterForm
...
...
@@ -24,6 +25,33 @@ registerForm =
<*>
areq
passwordField
"Password"
Nothing
<*>
areq
emailField
"Email"
Nothing
data
SearchUserForm
=
SearchUserForm
{
searchUserFormUsername
::
Maybe
Text
,
searchUserFormGroup
::
Maybe
Int64
,
searchUserFormSortBy
::
SortBy
,
searchUserFormAscending
::
Bool
}
searchUserForm
::
[
Entity
Groups
]
->
Form
SearchUserForm
searchUserForm
groups
=
renderDivs
$
SearchUserForm
<$>
aopt
textField
"Username"
Nothing
<*>
aopt
(
selectFieldList
glist
)
"Groups"
Nothing
<*>
areq
(
selectFieldList
slist
)
"Sort By"
Nothing
<*>
areq
(
selectFieldList
alist
)
"Sort Order"
Nothing
where
glist
::
[(
Text
,
Int64
)]
glist
=
map
(
\
x
->
(
pack
.
show
.
groupsGrouping
$
entityVal
x
,
fromSqlKey
.
entityKey
$
x
))
groups
slist
::
[(
Text
,
SortBy
)]
slist
=
map
(
pack
.
show
&&&
id
)
[
minBound
..
maxBound
]
alist
::
[(
Text
,
Bool
)]
alist
=
[(
"Ascending"
,
True
),
(
"Descending"
,
False
)]
getRegisterR
::
Handler
Html
getRegisterR
=
do
isNotLoggedIn
...
...
@@ -58,3 +86,35 @@ getUserR uid = do
(
ruid
,
name
,
group
)
<-
allowedToPost
user'
@
(
Entity
uid'
user
)
<-
getUserById
$
toSqlKey
uid
profileLayout
ruid
name
group
user'
$
(
widgetFile
"profile-info"
)
getUserListR
::
Handler
Html
getUserListR
=
do
(
uid
,
name
,
group
)
<-
allowedToPost
let
users
=
[]
::
[(
Grouping
,
Entity
Users
)]
ad
<-
getGroup
Administrator
mo
<-
getGroup
Moderator
me
<-
getGroup
Member
(
wid
,
enct
)
<-
generateFormPost
$
searchUserForm
[
ad
,
mo
,
me
]
defaultLayout
$
do
setTitle
"User List"
$
(
widgetFile
"user-list"
)
postUserListR
::
Handler
Html
postUserListR
=
do
(
uid
,
name
,
group
)
<-
allowedToPost
ad
<-
getGroup
Administrator
mo
<-
getGroup
Moderator
me
<-
getGroup
Member
((
res
,
wid
),
enct
)
<-
runFormPost
$
searchUserForm
[
ad
,
mo
,
me
]
case
res
of
FormSuccess
r
->
do
let
(
username
,
groupid
,
orderby
,
ascending
)
=
(
searchUserFormUsername
r
,
toSqlKey
<$>
searchUserFormGroup
r
,
searchUserFormSortBy
r
,
searchUserFormAscending
r
)
users
<-
searchUserByConditions
username
groupid
orderby
ascending
defaultLayout
$
do
setTitle
"User List"
$
(
widgetFile
"user-list"
)
_
->
error
""
templates/adm.hamlet
View file @
092932cd
...
...
@@ -6,7 +6,7 @@
<li .navigation-item>
<a .navigation-link href=@{AdmR} title="Management"> Management
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
<ul .navigation-list.float-right>
<li .navigation-item>
<a .navigation-link href=@{ProfileR}> Profile
...
...
templates/def.hamlet
View file @
092932cd
...
...
@@ -9,15 +9,15 @@
<li .navigation-item>
<a .navigation-link href=@{AdmR}> Administration
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Moderator
<li .navigation-item>
<a .navigation-link href=@{AdmR}> Administration
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Member
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Banned
<ul .navigation-list.float-right>
...
...
templates/profile.hamlet
View file @
092932cd
...
...
@@ -8,15 +8,15 @@
<li .navigation-item>
<a .navigation-link href=@{AdmR} title="Management"> Management
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Moderator
<li .navigation-item>
<a .navigation-link href=@{AdmR} title="Management"> Management
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Member
<li .navigation-item>
<a .navigation-link href=
"#"
title="Users"> Users
<a .navigation-link href=
@{UserListR}
title="Users"> Users
$of Banned
<ul .navigation-list.float-right>
<li .navigation-item>
...
...
templates/user-list.hamlet
0 → 100644
View file @
092932cd
<form method=post action=@{UserListR} enctype=#{enct}>
^{wid}
<input .button-primary name=search value=search type=submit>
<table>
<thead>
<tr>
<th> Username
<th> Title
<th> Posts
<th> Registered
<tbody>
$forall (group, Entity keyuser (Users _ uname email _ joined ts rp)) <- users
<tr>
<td>
<a href=@{UserR $ fromSqlKey keyuser}> #{uname}
<td> #{show group}
<td> #{rp}
<td> #{show $ utcToLocalTime timeZone joined}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment