forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Enable adding group members

Browse source
This commit is contained in:
fr33domlover 2016-05-26 16:25:23 +00:00
parent e2ef279515
commit ada42dea62
7 changed files with 197 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

@ -49,6 +49,7 @@ GroupMember
person PersonId
group GroupId
role GroupRole
joined UTCTime
UniqueGroupMember person group

66
src/Vervis/Field/Sharer.hs
View file

@ -16,15 +16,21 @@
module Vervis.Field.Sharer
( sharerIdentField
, newSharerIdentField
, existingSharerIdentField
, existingPersonIdentField
, existingGroupIdentField
, existingPersonNotMemberIdentField
)
where
import Prelude
import Control.Monad (void)
import Control.Monad.Trans.Maybe
import Data.Char (isDigit)
import Data.Maybe (isJust)
import Data.Maybe (isNothing, isJust)
import Data.Text (Text)
import Database.Esqueleto
import Database.Esqueleto hiding (isNothing)
import Yesod.Form.Fields (textField)
import Yesod.Form.Functions (checkBool, checkM, convertField)
import Yesod.Form.Types (Field)
@ -33,7 +39,7 @@ import Yesod.Persist.Core (runDB)
import qualified Data.Text as T (null, all, find, split)
import Data.Char.Local (isAsciiLetter)
import Vervis.Foundation (Handler)
import Vervis.Foundation (Handler, AppDB)
import Vervis.Model
import Vervis.Model.Ident (ShrIdent, shr2text, text2shr)
@ -64,3 +70,57 @@ sharerIdentField = convertField text2shr shr2text $ checkTemplate textField
newSharerIdentField :: Field Handler ShrIdent
newSharerIdentField = checkUniqueCI sharerIdentField
checkSharerExists :: Field Handler ShrIdent -> Field Handler ShrIdent
checkSharerExists = checkM $ \ shar -> do
r <- runDB $ getBy $ UniqueSharer shar
return $ if isJust r
then Right shar
else Left ("No such user or group" :: Text)
existingSharerIdentField :: Field Handler ShrIdent
existingSharerIdentField = checkSharerExists sharerIdentField
checkPersonExists :: Field Handler ShrIdent -> Field Handler ShrIdent
checkPersonExists = checkM $ \ shar -> do
r <- runDB $ runMaybeT $ do
Entity sid _s <- MaybeT $ getBy $ UniqueSharer shar
void $ MaybeT $ getBy $ UniquePersonIdent sid
return $ if isJust r
then Right shar
else Left ("No such user" :: Text)
existingPersonIdentField :: Field Handler ShrIdent
existingPersonIdentField = checkPersonExists sharerIdentField
checkGroupExists :: Field Handler ShrIdent -> Field Handler ShrIdent
checkGroupExists = checkM $ \ shar -> do
r <- runDB $ runMaybeT $ do
Entity sid _s <- MaybeT $ getBy $ UniqueSharer shar
void $ MaybeT $ getBy $ UniqueGroup sid
return $ if isJust r
then Right shar
else Left ("No such group" :: Text)
existingGroupIdentField :: Field Handler ShrIdent
existingGroupIdentField = checkGroupExists sharerIdentField
checkPersonExistsNotMember
:: AppDB GroupId -> Field Handler ShrIdent -> Field Handler ShrIdent
checkPersonExistsNotMember getgid = checkM $ \ pshar -> runDB $ do
mpid <- runMaybeT $ do
Entity s _ <- MaybeT $ getBy $ UniqueSharer pshar
Entity p _ <- MaybeT $ getBy $ UniquePersonIdent s
return p
case mpid of
Nothing -> return $ Left ("No such user" :: Text)
Just pid -> do
gid <- getgid
mm <- getBy $ UniqueGroupMember pid gid
return $ if isNothing mm
then Right pshar
else Left ("Already a member" :: Text)
existingPersonNotMemberIdentField :: AppDB GroupId -> Field Handler ShrIdent
existingPersonNotMemberIdentField getgid =
checkPersonExistsNotMember getgid sharerIdentField

25
src/Vervis/Form/Group.hs
View file

@ -16,18 +16,22 @@
module Vervis.Form.Group
( NewGroup (..)
, newGroupForm
, NewGroupMember (..)
, newGroupMemberForm
)
where
import Prelude
import Data.Text (Text)
import Yesod.Form.Fields (textField)
import Yesod.Form.Fields (textField, selectFieldList)
import Yesod.Form.Functions (aopt, areq, renderDivs)
import Yesod.Form.Types (AForm)
import Vervis.Field.Sharer (newSharerIdentField)
import Vervis.Foundation (Handler, Form)
import Vervis.Field.Sharer
import Vervis.Foundation (Handler, Form, AppDB)
import Vervis.Model
import Vervis.Model.Group (GroupRole (..))
import Vervis.Model.Ident (ShrIdent)
data NewGroup = NewGroup
@ -42,3 +46,18 @@ newGroupAForm = NewGroup
newGroupForm :: Form NewGroup
newGroupForm = renderDivs newGroupAForm
data NewGroupMember = NewGroupMember
{ ngmIdent :: ShrIdent
, ngmRole :: GroupRole
}
newGroupMemberAForm :: AppDB GroupId -> AForm Handler NewGroupMember
newGroupMemberAForm getgid = NewGroupMember
<$> areq (existingPersonNotMemberIdentField getgid) "Name*" Nothing
<*> areq (selectFieldList l) "Role*" Nothing
where
l = [("Admin" :: Text, GRAdmin), ("Member", GRMember)]
newGroupMemberForm :: AppDB GroupId -> Form NewGroupMember
newGroupMemberForm getgid = renderDivs $ newGroupMemberAForm getgid

99
src/Vervis/Foundation.hs
View file

@ -17,6 +17,7 @@ module Vervis.Foundation where
import Prelude (init, last)
import Control.Monad.Trans.Maybe
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym)
@ -32,6 +33,7 @@ import Data.Text as T (pack, intercalate)
import Text.Jasmine.Local (discardm)
import Vervis.Import.NoFoundation hiding (last)
import Vervis.Model.Group
import Vervis.Model.Ident
import Vervis.Widget (breadcrumbsW, revisionW)
@ -117,29 +119,65 @@ instance Yesod App where
-- Who can access which pages.
isAuthorized r w = case (r, w) of
(GroupsR , True) -> loggedIn
(GroupNewR , _) -> loggedIn
(GroupsR , True) -> personAny
(GroupNewR , _ ) -> personAny
(GroupMembersR grp , True) -> groupRole (== GRAdmin) grp
(GroupMemberNewR grp , _ ) -> groupRole (== GRAdmin) grp
(GroupMemberR grp _memb , True) -> groupRole (== GRAdmin) grp
(KeysR , _) -> loggedIn
(KeyR _key , _) -> loggedIn
(KeyNewR , _) -> loggedIn
(KeysR , _ ) -> personAny
(KeyR _key , _ ) -> personAny
(KeyNewR , _ ) -> personAny
(ReposR shar , True) -> loggedInAs shar
(RepoNewR user , _) -> loggedInAs user
(RepoR shar _ , True) -> loggedInAs shar
(ReposR shar , True) -> person shar
(RepoNewR user , _ ) -> person user
(RepoR shar _ , True) -> person shar
(ProjectsR shar , True) -> loggedInAs shar
(ProjectNewR user , _) -> loggedInAs user
(ProjectsR shar , True) -> person shar
(ProjectNewR user , _ ) -> person user
(TicketsR shar _ , True) -> loggedInAs shar
(TicketNewR _ _ , _) -> loggedIn
(TicketR user _ _ , True) -> loggedInAs user
(TicketEditR user _ _ , _) -> loggedInAs user
(TicketDiscussionR _ _ _ , True) -> loggedIn
(TicketMessageR _ _ _ _ , True) -> loggedIn
(TicketTopReplyR _ _ _ , _) -> loggedIn
(TicketReplyR _ _ _ _ , _) -> loggedIn
(TicketsR shar _ , True) -> person shar
(TicketNewR _ _ , _ ) -> personAny
(TicketR user _ _ , True) -> person user
(TicketEditR user _ _ , _ ) -> person user
(TicketDiscussionR _ _ _ , True) -> personAny
(TicketMessageR _ _ _ _ , True) -> personAny
(TicketTopReplyR _ _ _ , _ ) -> personAny
(TicketReplyR _ _ _ _ , _ ) -> personAny
_ -> return Authorized
where
personAnd
:: (Entity Person -> Handler AuthResult) -> Handler AuthResult
personAnd f = do
mp <- maybeAuth
case mp of
Nothing -> return AuthenticationRequired
Just p -> f p
personAny :: Handler AuthResult
personAny = personAnd $ \ _p -> return Authorized
person :: ShrIdent -> Handler AuthResult
person ident = personAnd $ \ (Entity _ p) -> do
let sid = personIdent p
sharer <- runDB $ getJust sid
return $ if ident == sharerIdent sharer
then Authorized
else Unauthorized "No access to this operation"
groupRole :: (GroupRole -> Bool) -> ShrIdent -> Handler AuthResult
groupRole role grp = personAnd $ \ (Entity pid _p) -> do
mrole <- runDB $ runMaybeT $ do
Entity sid _s <- MaybeT $ getBy $ UniqueSharer grp
Entity gid _g <- MaybeT $ getBy $ UniqueGroup sid
Entity _mid m <- MaybeT $ getBy $ UniqueGroupMember pid gid
return $ groupMemberRole m
return $ case mrole of
Nothing -> Unauthorized "Not a member of the group"
Just r ->
if role r
then Authorized
else Unauthorized "Not the expected group role"
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
@ -225,31 +263,6 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
loggedIn :: Handler AuthResult
loggedIn = do
mpid <- maybeAuthId
case mpid of
Nothing -> return AuthenticationRequired
Just _pid -> return Authorized
loggedInAs :: ShrIdent -> Handler AuthResult
loggedInAs ident = do
mp <- maybeAuth
case mp of
Nothing -> return AuthenticationRequired
Just (Entity _pid person) -> do
let sid = personIdent person
msharer <- runDB $ get sid
case msharer of
Nothing -> return $ Unauthorized $
"Integrity error: User " <>
personLogin person <>
" specified a nonexistent sharer ID"
Just sharer ->
return $ if ident == sharerIdent sharer
then Authorized
else Unauthorized "No access to this operation"
instance YesodBreadcrumbs App where
breadcrumb route = return $ case route of
StaticR _ -> ("", Nothing)

41
src/Vervis/Handler/Group.hs
View file

@ -80,6 +80,7 @@ postGroupsR = do
{ groupMemberPerson = pid
, groupMemberGroup = gid
, groupMemberRole = GRAdmin
, groupMemberJoined = now
}
insert_ member
redirect $ GroupR $ ngIdent ng
@ -119,13 +120,47 @@ getGroupMembersR shar = do
]
return sharer
return (s, ms)
defaultLayout $(widgetFile "group/members")
defaultLayout $(widgetFile "group/member/list")
getgid :: ShrIdent -> AppDB GroupId
getgid shar = do
Entity s _ <- getBy404 $ UniqueSharer shar
Entity g _ <- getBy404 $ UniqueGroup s
return g
postGroupMembersR :: ShrIdent -> Handler Html
postGroupMembersR shar = error "Not implemented"
postGroupMembersR shar = do
((result, widget), enctype) <-
runFormPost $ newGroupMemberForm $ getgid shar
case result of
FormSuccess ngm -> do
now <- liftIO getCurrentTime
runDB $ do
gid <- getgid shar
pid <- do
Entity s _ <- getBy404 $ UniqueSharer $ ngmIdent ngm
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
let member = GroupMember
{ groupMemberPerson = pid
, groupMemberGroup = gid
, groupMemberRole = ngmRole ngm
, groupMemberJoined = now
}
insert_ member
redirect $ GroupMemberR shar $ ngmIdent ngm
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "group/member/new")
FormFailure _l -> do
setMessage "Member insertion failed, see errors below"
defaultLayout $(widgetFile "group/member/new")
getGroupMemberNewR :: ShrIdent -> Handler Html
getGroupMemberNewR shar = error "Not implemented"
getGroupMemberNewR shar = do
((_result, widget), enctype) <-
runFormPost $ newGroupMemberForm $ getgid shar
defaultLayout $(widgetFile "group/member/new")
getGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
getGroupMemberR grp memb = error "Not implemented"

0
templates/group/members.hamlet → templates/group/member/list.hamlet
View file

17
templates/group/member/new.hamlet Normal file
View file

@ -0,0 +1,17 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{GroupMembersR shar} enctype=#{enctype}>
^{widget}
<input type=submit>