Commit 8986abd4 authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

ban management.

parent 0ee09cbc
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 01d9b30cb49341b29189cabdcccfe7d240125e2be98744aac73ca82059e08a55
-- hash: 182b2eee735aff45f4d879dc8c683cf136a2a4a06e7bf266979d7a09220b6f88
name: Cirkeltrek
version: 0.0.0
......@@ -12,20 +12,23 @@ cabal-version: >= 1.10
library
exposed-modules:
Application
DBOp.CRUDBan
DBOp.CRUDCategory
DBOp.CRUDForum
DBOp.CRUDGroup
DBOp.CRUDPost
DBOp.CRUDTopic
DBOp.CRUDUser
Flux.AdmCategory
Flux.AdmForum
Flux.Adm.Ban
Flux.Adm.Category
Flux.Adm.Forum
Flux.Forum
Flux.Home
Flux.Post
Flux.Topic
Flux.User
Foundation
Handler.Adm.Ban
Handler.Adm.Category
Handler.Adm.Forum
Handler.Forum
......
......@@ -29,6 +29,7 @@ import Handler.Home
import Handler.User
import Handler.Adm.Category
import Handler.Adm.Forum
import Handler.Adm.Ban
import Handler.Forum
import Handler.Topic
import Handler.Post
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module DBOp.CRUDBan where
import Import hiding (Value, groupBy, on, update, (+=.),
(=.), (==.), (||.))
import Database.Esqueleto
insertBan ::
(BaseBackend backend ~ SqlBackend, PersistStoreWrite backend, MonadIO m)
=> Text
-> Maybe Text
-> Maybe Text
-> Key Users
-> ReaderT backend m ()
insertBan bannedsUsername bannedsIp bannedsMessage bannedsExecutor =
let bannedsStillInEffect = True
in insert_ Banneds {..}
selectAllBanneds ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> ReaderT backend m [(Value (Key Users), Entity Banneds, Value Text)]
selectAllBanneds = do
select $
from $ \(user, banned, exec) -> do
where_
(user ^. UsersUsername ==. banned ^. BannedsUsername
&&. banned ^. BannedsExecutor ==. exec ^. UsersId
&&. banned ^. BannedsStillInEffect ==. val True)
return (user ^. UsersId, banned, exec ^. UsersUsername)
updateBan username ip message exec status = do
update $ \banned -> do
set
banned
[ BannedsIp =. val ip
, BannedsMessage =. val message
, BannedsExecutor =. val exec
, BannedsStillInEffect =. val status
]
where_ (banned ^. BannedsUsername ==. val username)
......@@ -12,9 +12,34 @@ import Import hiding (Value, groupBy, on,
import Database.Esqueleto
selectGroupByGrouping ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Grouping
-> ReaderT backend m [Entity Groups]
selectGroupByGrouping groupname = do
select $
from $ \group -> do
where_ (group ^. GroupsGrouping ==. val groupname)
limit 1
return group
selectGroupByUsername ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> ReaderT backend m [(Value (Key Users), Value (Key Groups), Value Grouping)]
selectGroupByUsername username = do
select $
from $ \(user, group) -> do
where_
(user ^. UsersGroupId ==. group ^. GroupsId
&&. user ^. UsersUsername ==. val username)
limit 1
return (user ^. UsersId, group ^. GroupsId, group ^. GroupsGrouping)
......@@ -12,6 +12,8 @@ import Import hiding (Value, groupBy, on, update, (+=.),
import Database.Esqueleto
import DBOp.CRUDGroup
insertUser ::
(BaseBackend backend ~ SqlBackend, PersistStoreWrite backend, MonadIO m)
=> Key Groups
......@@ -57,3 +59,11 @@ selectUserByUsernameOrEmail username email = do
val email)
limit 1
return user
updateUserGroupingByUsername ::
MonadIO m => Text -> Grouping -> ReaderT SqlBackend m ()
updateUserGroupingByUsername username grouping = do
[x] <- selectGroupByGrouping grouping
update $ \user -> do
set user [UsersGroupId =. val (entityKey x)]
where_ (user ^. UsersUsername ==. val username)
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.Adm.Ban where
import Import hiding (Value)
import Database.Esqueleto
import DBOp.CRUDBan
import DBOp.CRUDGroup
import DBOp.CRUDUser
getAllBanneds ::
( BackendCompatible SqlBackend (YesodPersistBackend site)
, PersistQueryRead (YesodPersistBackend site)
, PersistUniqueRead (YesodPersistBackend site)
, YesodPersist site
)
=> HandlerFor site [( Value (Key Users)
, Entity Banneds
, Value Text)]
getAllBanneds = liftHandler $ runDB $ selectAllBanneds
banUser execid execname execgroup username ip message = do
gusername <- liftHandler $ runDB $ selectGroupByUsername username
case gusername of
[] -> invalidArgs ["There's no user named " <> username]
x:_ -> do
let (uid, gid, group) = (\(Value u, Value gi, Value g) -> (u, gi, g)) x
case (banResult execgroup group, execid == uid) of
(Right _, False) -> do
liftHandler $ runDB $ do
updateUserGroupingByUsername username Banned
insertBan username ip message execid
(Right _, True) -> invalidArgs ["You cannot ban yourself."]
(Left x, _) -> invalidArgs [x]
unbanUser ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Users
-> p
-> Grouping
-> Text
-> m ()
unbanUser execid execname execgroup username = do
gusernames <- liftHandler $ runDB $ selectGroupByUsername username
case gusernames of
[] -> invalidArgs ["There's no user named " <> username]
x:_ -> do
let (uid, gid, group) = (\(Value u, Value gi, Value g) -> (u, gi, g)) x
case (unbanResult execgroup group, execid == uid) of
(Right _, False) -> do
liftHandler $ runDB $ do
updateUserGroupingByUsername username Member
updateBan username Nothing Nothing execid False
(Right _, True) -> invalidArgs ["You cannot unban yourself."]
(Left x, _) -> invalidArgs [x]
unbanResult Administrator Banned = Right ()
unbanResult Moderator Banned = Right ()
unbanResult Administrator _ = Left "Cannot unban non-banned"
unbanResult Moderator _ = Left "Cannot unban non-banned"
unbanResult _ _ = Left "You have no right to do so."
banResult Administrator Administrator = Left "Cannot ban an Admin"
banResult Administrator Moderator = Left "Cannot ban a Mod"
banResult Administrator Member = Right ()
banResult Administrator Banned = Left "Cannot ban an already banned user."
banResult Moderator Administrator = Left "It's above your paygrade."
banResult Moderator Moderator = Left "Cannot ban a Mod"
banResult Moderator Member = Right ()
banResult _ _ = Left "You're not allowed to ban something."
......@@ -3,8 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.AdmCategory where
module Flux.Adm.Category where
import Import
......
......@@ -4,8 +4,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Flux.AdmForum where
module Flux.Adm.Forum where
import Import hiding (Value)
......
......@@ -64,11 +64,22 @@ getPostParentInformation pid = do
[] -> notFound
x:_ -> return x
editPostByUidGroupAndContent ::
( YesodPersistBackend (HandlerSite m) ~ SqlBackend
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Users
-> Grouping
-> Key Posts
-> Key Users
-> Text
-> m ()
editPostByUidGroupAndContent _ group pid _ content
| group == Administrator || group == Moderator =
liftHandler $ runDB $ updatePostContent pid content
editPostByUidGroupAndContent _ Banned _ _ _ =
permissionDenied "Bruh... You've been banned. Please..."
editPostByUidGroupAndContent uid _ pid uid' content
editPostByUidGroupAndContent uid Member pid uid' content
| uid /= uid' = permissionDenied "You're not allowed to edit this post."
| otherwise = liftHandler $ runDB $ updatePostContent pid content
......@@ -33,20 +33,22 @@ 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/category AdmCategoryR GET POST
/admin/forum AdmForumR 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/category AdmCategoryR GET POST
/admin/forum AdmForumR GET POST
/admin/ban AdmBanR GET POST
/admin/ban/options AdmBanOptionsR 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)
......@@ -148,17 +150,24 @@ instance YesodAuth App where
instance YesodAuthPersist App
allowedToAdmin :: Handler (Key Users, Text, Grouping)
allowedToAdmin = do
midnamegroup <- getUserAndGrouping
case midnamegroup of
Nothing -> permissionDenied "You're not allowed to see this page."
(Just (uid, name, Administrator)) -> return (uid, name, Administrator)
(Just (uid, name, _)) -> permissionDenied "You're not the admin of this site."
allowedToPost :: Handler (Key Users, Text, Grouping)
allowedToPost = do
midnamegroup <- getUserAndGrouping
case midnamegroup of
Nothing -> permissionDenied "You're not allowed to see this page."
(Just (uid, name, Banned)) -> permissionDenied "You're banned."
(Just (uid, name, _)) -> return (uid, name, Administrator)
(Just (uid, name, group)) -> return (uid, name, group)
allowedToMod :: Handler (Key Users, Text, Grouping)
allowedToMod = do
(uid, name, group) <- allowedToPost
case group of
x | x == Administrator || x == Moderator -> return (uid, name, group)
otherwise -> permissionDenied "You are not allowed to moderate this site."
allowedToAdmin :: Handler (Key Users, Text, Grouping)
allowedToAdmin = do
(uid, name, group) <- allowedToPost
case group of
Administrator -> return (uid, name, group)
_ -> permissionDenied "You are not allowed to administer this site."
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Adm.Ban where
import Import
import Database.Esqueleto
import Flux.Adm.Ban
data BanUserForm = BanUserForm
{ banUserFormUsername :: Text
} deriving (Show)
data BanUserOptionsForm = BanUserOptionsForm
{ banUserOptionsFormUsername :: Text
, banUserOptionsFormIp ::Maybe Text
, banUserOptionsFormMessage ::Maybe Textarea
}
banUserOptionsForm :: Text -> Form BanUserOptionsForm
banUserOptionsForm username =
renderDivs $ BanUserOptionsForm
<$> areq textField "Username" (Just username)
<*> aopt textField "IP" Nothing
<*> aopt textareaField "Message" Nothing
banUserForm :: Form BanUserForm
banUserForm = renderDivs $ BanUserForm <$> areq textField "Username" Nothing
getAdmBanR :: Handler Html
getAdmBanR = do
(uid, name, gruop) <- allowedToMod
(wid, enct) <- generateFormPost banUserForm
bans <- getAllBanneds
let banneds = map (\(Value uid, b, Value ename) -> (uid, b, ename)) bans
defaultLayout $(widgetFile "adm-ban")
postAdmBanR :: Handler Html
postAdmBanR = do
(uid, name, group) <- allowedToMod
names <- lookupPostParams "username"
ban <- lookupPostParam "ban"
case (names, ban) of
([], Nothing) -> invalidArgs ["Make up your mind!"]
([], Just _) -> do
((res, _), _) <- runFormPost $ banUserOptionsForm "x"
case res of
FormSuccess r -> do
banUser
uid
name
group
(banUserOptionsFormUsername r)
(banUserOptionsFormIp r)
(unTextarea <$> banUserOptionsFormMessage r)
redirect $ AdmBanR
_ -> invalidArgs ["Your input is not correct."]
(xs, Just _) -> invalidArgs ["Make up your mind!"]
(xs, Nothing) -> do
forM_ names $ unbanUser uid name group
redirect AdmBanR
postAdmBanOptionsR :: Handler Html
postAdmBanOptionsR = do
(uid, name, group) <- allowedToMod
((res, _), _) <- runFormPost banUserForm
case res of
FormSuccess r -> do
(wid, enct) <-
generateFormPost . banUserOptionsForm . banUserFormUsername $ r
defaultLayout $(widgetFile "adm-ban-options")
_ -> invalidArgs ["Fill your input correctly."]
......@@ -7,7 +7,7 @@ import Import
import Database.Esqueleto
import Flux.AdmCategory
import Flux.Adm.Category
data CreateCategoryForm = CreateCategoryForm
{ createCategoryFormName :: Text
......
......@@ -7,8 +7,8 @@ import Import
import Database.Esqueleto
import Flux.AdmCategory
import Flux.AdmForum
import Flux.Adm.Category
import Flux.Adm.Forum
data CreateForumForm = CreateForumForm
{ createForumFormName :: Text
......
......@@ -49,7 +49,7 @@ postPostEditR pid = do
editPostByUidGroupAndContent
uid
group
(toSqlKey pid )
(toSqlKey pid)
(postsUserId $ entityVal post)
(unTextarea $ editPostFormContent c)
redirect $ PostR pid
......
......@@ -36,8 +36,9 @@ postTopicR tid = do
redirect $ TopicPageR tid page :#: ("post-" <> show num)
_ -> defaultLayout [whamlet|Please.|]
canEdit uid puid group =
uid == puid || group == Administrator || group == Moderator
canEdit :: Key Users -> Key Users -> Grouping -> Bool
canEdit uid posterid group =
uid == posterid || group == Administrator || group == Moderator
getTopicPageR :: Int64 -> Int64 -> Handler Html
getTopicPageR tid page = do
......
<h3> Ban User
<.row>
<.column.column-100>
<form action=@{AdmBanR} method=post encttype=#{enct}>
^{wid}
<input .button name=ban value=ban type=submit>
<h3> Ban User
<.row>
<.column.column-100>
<form action=@{AdmBanOptionsR} method=post encttype=#{enct}>
^{wid}
<input .button name=ban value=ban type=submit>
<h4> Banned Users
<form method=post action=@{AdmBanR}>
<table>
<thead>
<th> Username
<th> IP
<th> Message
<th> Executed By
<th>
<tbody>
$forall (uid, banned, ename) <- banneds
<tr>
<td>
<a href=@{UserR $ fromSqlKey uid}> #{bannedsUsername $ entityVal banned}
$maybe bip <- (bannedsIp $ entityVal banned)
<td> #{bip}
$nothing
<td>
$maybe bm <- (bannedsMessage $ entityVal banned)
<td> #{bm}
$nothing
<td>
<td>
<a href=@{UserR $ fromSqlKey $ bannedsExecutor $ entityVal banned}> #{ename}
<td>
<input name=username value=#{bannedsUsername $ entityVal banned} type=checkbox>
<input .button name=unban value=unban type=submit>
......@@ -5,7 +5,7 @@
<span> »
<a href=@{TopicR tid}> #{topicsSubject $ entityVal topic}
$forall (Entity pid (Posts tid n uname uid' t content)) <- posts
$forall (Entity pid (Posts tid n uname posterid t content)) <- posts
<.row.row-no-padding>
<.column.column-100>
<span>#{show $ utcToLocalTime timeZone $ t}
......@@ -18,9 +18,10 @@ $forall (Entity pid (Posts tid n uname uid' t content)) <- posts
<.column.column-100> #{content}
<.row.row-no-padding>
<.column.column-10.column-offset-80>
$if canEdit uid uid' group
$if canEdit uid posterid group
<span .float-right>
<a href=@{PostEditR $ fromSqlKey pid}> Edit
$else
<.column.column-10>
<span .float-right #post-#{n}> Report
......
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