Enable adding group members

config/models

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

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

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.Field.Sharer
-import Vervis.Foundation (Handler, Form)
+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

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
+        (GroupsR                 , True) -> personAny
-        (GroupNewR               , _)    -> loggedIn
+        (GroupNewR               , _   ) -> personAny
+        (GroupMembersR grp       , True) -> groupRole (== GRAdmin) grp
+        (GroupMemberNewR grp     , _   ) -> groupRole (== GRAdmin) grp
+        (GroupMemberR grp _memb  , True) -> groupRole (== GRAdmin) grp
 
-        (KeysR                   , _)    -> loggedIn
+        (KeysR                   , _   ) -> personAny
-        (KeyR _key               , _)    -> loggedIn
+        (KeyR _key               , _   ) -> personAny
-        (KeyNewR                 , _)    -> loggedIn
+        (KeyNewR                 , _   ) -> personAny
 
-        (ReposR shar             , True) -> loggedInAs shar
+        (ReposR shar             , True) -> person shar
-        (RepoNewR user           , _)    -> loggedInAs user
+        (RepoNewR user           , _   ) -> person user
-        (RepoR shar _            , True) -> loggedInAs shar
+        (RepoR shar _            , True) -> person shar
 
-        (ProjectsR shar          , True) -> loggedInAs shar
+        (ProjectsR shar          , True) -> person shar
-        (ProjectNewR user        , _)    -> loggedInAs user
+        (ProjectNewR user        , _   ) -> person user
 
-        (TicketsR shar _         , True) -> loggedInAs shar
+        (TicketsR shar _         , True) -> person shar
-        (TicketNewR _ _          , _)    -> loggedIn
+        (TicketNewR _ _          , _   ) -> personAny
-        (TicketR user _ _        , True) -> loggedInAs user
+        (TicketR user _ _        , True) -> person user
-        (TicketEditR user _ _    , _)    -> loggedInAs user
+        (TicketEditR user _ _    , _   ) -> person user
-        (TicketDiscussionR _ _ _ , True) -> loggedIn
+        (TicketDiscussionR _ _ _ , True) -> personAny
-        (TicketMessageR _ _ _ _  , True) -> loggedIn
+        (TicketMessageR _ _ _ _  , True) -> personAny
-        (TicketTopReplyR _ _ _   , _)    -> loggedIn
+        (TicketTopReplyR _ _ _   , _   ) -> personAny
-        (TicketReplyR _ _ _ _    , _)    -> loggedIn
+        (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)

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"

templates/group/member/new.hamlet

@@ -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>