diff --git a/config/models b/config/models index f63d92b..873a337 100644 --- a/config/models +++ b/config/models @@ -49,6 +49,7 @@ GroupMember person PersonId group GroupId role GroupRole + joined UTCTime UniqueGroupMember person group diff --git a/src/Vervis/Field/Sharer.hs b/src/Vervis/Field/Sharer.hs index b490e96..6a10083 100644 --- a/src/Vervis/Field/Sharer.hs +++ b/src/Vervis/Field/Sharer.hs @@ -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 diff --git a/src/Vervis/Form/Group.hs b/src/Vervis/Form/Group.hs index 2b87a55..a96d014 100644 --- a/src/Vervis/Form/Group.hs +++ b/src/Vervis/Form/Group.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 718d691..4485ab6 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 74623fd..2b56252 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -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" diff --git a/templates/group/members.hamlet b/templates/group/member/list.hamlet similarity index 100% rename from templates/group/members.hamlet rename to templates/group/member/list.hamlet diff --git a/templates/group/member/new.hamlet b/templates/group/member/new.hamlet new file mode 100644 index 0000000..58ff088 --- /dev/null +++ b/templates/group/member/new.hamlet @@ -0,0 +1,17 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + +
+ ^{widget} +