Commit 24c0c6cb authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

administer user. promote.

parent f75c4acc
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: f7806638b41817081e52bb64d51bae3ad469281b2edb3ace88ef289fce09ff1a
-- hash: 62d7c6c506dc8823a51cbe13d0a09a1cf64d63da543b3fda96391eff8a67dfb3
name: Cirkeltrek
version: 0.0.0
......@@ -22,6 +22,7 @@ library
Flux.Adm.Ban
Flux.Adm.Category
Flux.Adm.Forum
Flux.Adm.User
Flux.Forum
Flux.Home
Flux.Miscellaneous
......
......@@ -73,3 +73,18 @@ selectAllGroups = do
from $ \group -> do
orderBy [asc (group ^. GroupsGrouping)]
return group
selectGroupByGroupId ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Groups
-> ReaderT backend m [Entity Groups]
selectGroupByGroupId gid = do
select $
from $ \group -> do
where_ (group ^. GroupsId ==. val gid)
limit 1
return group
......@@ -68,6 +68,16 @@ updateUserGroupingByUsername username grouping = do
set user [UsersGroupId =. val (entityKey x)]
where_ (user ^. UsersUsername ==. val username)
selectUsersByConditions ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Maybe (Key Groups)
-> Maybe Text
-> Maybe Text
-> ReaderT backend m [(Entity Users, Value Grouping)]
selectUsersByConditions mgid musername memail = do
select $
from $ \(user, group) -> do
......
......@@ -24,6 +24,18 @@ getAllBanneds ::
, Value Text)]
getAllBanneds = liftHandler $ runDB $ selectAllBanneds
banUser ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Users
-> p
-> Grouping
-> Text
-> Maybe Text
-> Maybe Text
-> m ()
banUser execid execname execgroup username ip message = do
gusername <- liftHandler $ runDB $ selectGroupByUsername username
case gusername of
......@@ -38,6 +50,18 @@ banUser execid execname execgroup username ip message = do
(Right _, True) -> invalidArgs ["You cannot ban yourself."]
(Left x, _) -> invalidArgs [x]
banUserById ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Users
-> p
-> Grouping
-> Key Users
-> Maybe Text
-> Maybe Text
-> m ()
banUserById execid execname execgroup userid ip message = do
[user] <- liftHandler $ runDB $ selectUserById userid
banUser execid execname execgroup (usersUsername $ entityVal user) ip message
......@@ -48,7 +72,7 @@ unbanUser ::
, MonadHandler m
)
=> Key Users
-> p
-> Text
-> Grouping
-> Text
-> m ()
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Flux.Adm.User where
import Import hiding (Value)
import Database.Esqueleto
import DBOp.CRUDGroup
import DBOp.CRUDUser
import DBOp.CRUDBan
import Flux.Miscellaneous
import Flux.User
import Flux.Adm.Ban
promoteUser ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, MonadHandler m
)
=> Key Users
-> Text
-> Grouping
-> Key Users
-> Key Groups
-> m ()
promoteUser execid execname execgroup targetid targetgroupid = do
guardUser execid targetid
guardGroup execgroup
enttargetuser <- getUserById targetid
enttargetgroup <- getGroupById targetgroupid
let username = usersUsername $ entityVal enttargetuser
group = groupsGrouping $ entityVal enttargetgroup
liftHandler . runDB $ do
updateUserGroupingByUsername username Member
updateBan username Nothing Nothing execid False
updateUserGroupingByUsername username group
where
guardUser xid tid =
if xid /= tid
then return ()
else invalidArgs ["Cannot promote or demote yourself."]
guardGroup Administrator = return ()
guardGroup _ = invalidArgs ["Only admin allowed to promote."]
......@@ -5,9 +5,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Flux.Miscellaneous where
import Import
import Import
import DBOp.CRUDGroup
import DBOp.CRUDGroup
getAllGroups ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
......@@ -18,3 +18,33 @@ getAllGroups ::
)
=> m [Entity Groups]
getAllGroups = liftHandler $ runDB $ selectAllGroups
getGroup ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Grouping
-> m (Entity Groups)
getGroup x = do
a <- liftHandler . runDB . selectGroupByGrouping $ x
case a of
[g] -> return g
_ -> invalidArgs ["Group not found."]
getGroupById ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Groups
-> m (Entity Groups)
getGroupById gid = do
a <- liftHandler . runDB . selectGroupByGroupId $ gid
case a of
[g] -> return g
_ -> invalidArgs ["Group not found."]
......@@ -12,6 +12,7 @@ import Database.Esqueleto
import Flux.Miscellaneous
import Flux.User
import Flux.Adm.Ban
import Flux.Adm.User
data SearchUserForm = SearchUserForm
{ searchUserFormGroupId :: Maybe Int64
......@@ -45,6 +46,21 @@ banUsersOptionsForm userid =
<$> aopt textField "Message" Nothing
<*> areq hiddenField "" (Just userid)
data PromoteUsersForm = PromoteUsersForm
{ promoteUsersFormGroupId :: Int64
, promoteUsersFormUserIds :: Text
} deriving (Show)
promoteUsersForm :: [Entity Groups] -> Text -> Form PromoteUsersForm
promoteUsersForm groups userids =
renderDivs $ PromoteUsersForm
<$> areq (selectFieldList glist) "Group" Nothing
<*> areq hiddenField "" (Just userids)
where
glist :: [(Text, Int64)]
glist =
map (\(Entity cid (Groups g)) -> (pack $ show g, fromSqlKey cid)) groups
groupToHtml :: Grouping -> Html
groupToHtml = toHtml . show
......@@ -82,8 +98,20 @@ postAdmUserPromoteR = do
case promote of
Just "ban" -> do
(uid, name, group) <- allowedToMod
let ban = True
(wid, enct) <-
generateFormPost $ banUsersOptionsForm $ intercalate "," userids
adminLayout uid name group $ do
setTitle "ban"
$(widgetFile "adm-user-promote")
Just "change" -> do
(uid, name, group) <- allowedToAdmin
let ban = False
mo <- getGroup Moderator
me <- getGroup Member
(wid, enct) <-
generateFormPost $
promoteUsersForm [mo, me] $ intercalate "," userids
adminLayout uid name group $ do
setTitle "Promote"
$(widgetFile "adm-user-promote")
......@@ -105,6 +133,18 @@ postAdmUserPromoteExeR = do
forM_ userids $ \userid ->
banUserById uid name group (toSqlKey userid) Nothing mes
redirect $ AdmUserR
Just "change" -> do
error "Change"
Just "promote" -> do
(uid, name, group) <- allowedToAdmin
mo <- getGroup Moderator
me <- getGroup Member
((res, _), _) <- runFormPost $ promoteUsersForm [mo, me] ""
case res of
FormSuccess r -> do
let (gid, userids) =
( promoteUsersFormGroupId r
, map forceTextToInt64 $ splitOn "," $ promoteUsersFormUserIds r)
forM_ userids $ \userid ->
promoteUser uid name group (toSqlKey userid) (toSqlKey gid)
redirect AdmUserR
_ -> invalidArgs ["Please..."]
_ -> invalidArgs ["Can't understand that."]
......@@ -2,7 +2,10 @@ $case group
$of Administrator
<form [email protected]{AdmUserPromoteExeR} method=post encttype=#{enct}>
^{wid}
<input .button name=promote value=ban type=submit>
$if ban
<input .button name=promote value=ban type=submit>
$else
<input .button name=promote value=promote type=submit>
$of Moderator
<form [email protected]{AdmUserPromoteExeR} method=post encttype=#{enct}>
^{wid}
......
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