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

administer user. ban.

parent d83b2a0d
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: be478473889e1800099c7765403b2d8cd40e42891190aaa39a9ddd3be71daf73
-- hash: f7806638b41817081e52bb64d51bae3ad469281b2edb3ace88ef289fce09ff1a
name: Cirkeltrek
version: 0.0.0
......@@ -68,6 +68,7 @@ library
, persistent-template
, shakespeare
, template-haskell
, text
, time
, wai
, wai-extra
......@@ -108,6 +109,7 @@ executable Cirkeltrek
, persistent-template
, shakespeare
, template-haskell
, text
, time
, wai
, wai-extra
......@@ -148,6 +150,7 @@ executable Seed
, persistent-template
, shakespeare
, template-haskell
, text
, time
, wai
, wai-extra
......
......@@ -19,6 +19,7 @@ dependencies:
- persistent-postgresql
- shakespeare
- template-haskell
- text
- time
- yaml
- yesod
......
......@@ -44,6 +44,23 @@ selectGroupByUsername username = do
limit 1
return (user ^. UsersId, group ^. GroupsId, group ^. GroupsGrouping)
selectGroupByUserId ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Users
-> ReaderT backend m [(Value (Key Users), Value (Key Groups), Value Grouping)]
selectGroupByUserId userid = do
select $
from $ \(user, group) -> do
where_
(user ^. UsersGroupId ==. group ^. GroupsId
&&. user ^. UsersId ==. val userid)
limit 1
return (user ^. UsersId, group ^. GroupsId, group ^. GroupsGrouping)
selectAllGroups ::
( PersistUniqueRead backend
, PersistQueryRead backend
......
......@@ -38,6 +38,10 @@ banUser execid execname execgroup username ip message = do
(Right _, True) -> invalidArgs ["You cannot ban yourself."]
(Left x, _) -> invalidArgs [x]
banUserById execid execname execgroup userid ip message = do
[user] <- liftHandler $ runDB $ selectUserById userid
banUser execid execname execgroup (usersUsername $ entityVal user) ip message
unbanUser ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
......
......@@ -33,24 +33,26 @@ data App = App
mkYesodData
"App"
[parseRoutes|
/ HomeR GET
/static StaticR Static appStatic
/auth SigninR Auth getAuth
/register RegisterR GET POST
/profile ProfileR GET
/user/#Int64 UserR GET
/admin AdmR GET
/admin/category AdmCategoryR GET POST
/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
/topic/#Int64/#Int64 TopicPageR GET
/post/#Int64 PostR GET
/post/#Int64/edit PostEditR GET POST
/ HomeR GET
/static StaticR Static appStatic
/auth SigninR Auth getAuth
/register RegisterR GET POST
/profile ProfileR GET
/user/#Int64 UserR GET
/admin AdmR GET
/admin/category AdmCategoryR GET POST
/admin/forum AdmForumR GET POST
/admin/ban AdmBanR GET POST
/admin/ban/options AdmBanOptionsR POST
/admin/user AdmUserR GET POST
/admin/user/promote AdmUserPromoteR POST
/admin/user/promote/exe AdmUserPromoteExeR POST
/forum/#Int64 ForumR GET POST
/forum/#Int64/#Int64 ForumPageR GET
/topic/#Int64 TopicR GET POST
/topic/#Int64/#Int64 TopicPageR GET
/post/#Int64 PostR GET
/post/#Int64/edit PostEditR GET POST
|]
type Form a = Html -> MForm (HandlerFor App) (FormResult a, Widget)
......
......@@ -6,10 +6,12 @@ module Handler.Adm.User where
import Import
import Data.Text (splitOn)
import Database.Esqueleto
import Flux.Miscellaneous
import Flux.User
import Flux.Adm.Ban
data SearchUserForm = SearchUserForm
{ searchUserFormGroupId :: Maybe Int64
......@@ -17,9 +19,6 @@ data SearchUserForm = SearchUserForm
, searchUserFormEmail :: Maybe Text
}
groupToHtml :: Grouping -> Html
groupToHtml = toHtml . show
searchUserForm :: [Entity Groups] -> Form SearchUserForm
searchUserForm groups =
renderDivs $ SearchUserForm
......@@ -35,6 +34,20 @@ searchUserForm groups =
, fromSqlKey . entityKey $ x))
groups
data BanUsersOptionsForm = BanUsersOptionsForm
{ banUsersOptionsFormMessessage :: Maybe Text
, banUsersOptionsFormIds :: Text
}
banUsersOptionsForm :: Text -> Form BanUsersOptionsForm
banUsersOptionsForm userid =
renderDivs $ BanUsersOptionsForm
<$> aopt textField "Message" Nothing
<*> areq hiddenField "" (Just userid)
groupToHtml :: Grouping -> Html
groupToHtml = toHtml . show
getAdmUserR :: Handler Html
getAdmUserR = do
(uid, name, group) <- allowedToMod
......@@ -61,3 +74,37 @@ postAdmUserR = do
adminLayout uid name group $ do
setTitle "Users"
$(widgetFile "adm-user")
postAdmUserPromoteR :: Handler Html
postAdmUserPromoteR = do
promote <- lookupPostParam "promote"
userids <- lookupPostParams "user-id"
case promote of
Just "ban" -> do
(uid, name, group) <- allowedToMod
(wid, enct) <-
generateFormPost $ banUsersOptionsForm $ intercalate "," userids
adminLayout uid name group $ do
setTitle "Promote"
$(widgetFile "adm-user-promote")
_ -> invalidArgs ["What do you want to do with the users?"]
postAdmUserPromoteExeR :: Handler Html
postAdmUserPromoteExeR = do
promote <- lookupPostParam "promote"
case promote of
Nothing -> invalidArgs ["No promote param."]
Just "ban" -> do
(uid, name, group) <- allowedToMod
((res, wid), enct) <- runFormPost $ banUsersOptionsForm ""
case res of
FormSuccess r -> do
let (mes, userids) =
( banUsersOptionsFormMessessage r
, map forceTextToInt64 $ splitOn "," $ banUsersOptionsFormIds r)
forM_ userids $ \userid ->
banUserById uid name group (toSqlKey userid) Nothing mes
redirect $ AdmUserR
Just "change" -> do
error "Change"
_ -> invalidArgs ["Can't understand that."]
$case group
$of Administrator
<form action=@{AdmUserPromoteExeR} method=post encttype=#{enct}>
^{wid}
<input .button name=promote value=ban type=submit>
$of Moderator
<form action=@{AdmUserPromoteExeR} method=post encttype=#{enct}>
^{wid}
<input .button name=promote value=ban type=submit>
$of _
......@@ -4,7 +4,7 @@
<input .button name=search value=search type=submit>
<h4> Result
<form action="#" method=post enctype=#{enct}>
<form action=@{AdmUserPromoteR} method=post enctype=#{enct}>
<table>
<thead>
<th> Username
......
......@@ -8,10 +8,16 @@
$of Administrator
<li .navigation-item>
<a .navigation-link href=@{AdmR}> Administration
<li .navigation-item>
<a .navigation-link href="#" title="Users"> Users
$of Moderator
<li .navigation-item>
<a .navigation-link href=@{AdmR}> Administration
<li .navigation-item>
<a .navigation-link href="#" title="Users"> Users
$of Member
<li .navigation-item>
<a .navigation-link href="#" title="Users"> Users
$of Banned
<ul .navigation-list.float-right>
......
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