Write missing group member routes

src/Vervis/Handler/Group.hs

@@ -32,7 +32,8 @@ import Prelude
 import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (getCurrentTime)
-import Database.Esqueleto
+import Database.Esqueleto hiding ((==.), (!=.), delete)
+import Database.Persist
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuthId)
 import Yesod.Core (defaultLayout, setMessage)
@@ -41,6 +42,8 @@ import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, getBy404)
 
+import qualified Database.Esqueleto as E
+
 import Vervis.Form.Group
 import Vervis.Foundation
 import Vervis.Model
@@ -53,7 +56,7 @@ import Vervis.Widget.Sharer (groupLinkW, personLinkW)
 getGroupsR :: Handler Html
 getGroupsR = do
     groups <- runDB $ select $ from $ \ (sharer, group) -> do
-        where_ $ sharer ^. SharerId ==. group ^. GroupIdent
+        where_ $ sharer ^. SharerId E.==. group ^. GroupIdent
         orderBy [asc $ sharer ^. SharerIdent]
         return sharer
     defaultLayout $(widgetFile "group/list")
@@ -111,9 +114,9 @@ getGroupMembersR shar = do
         Entity gid _g <- getBy404 $ UniqueGroup sid
         ms <- select $ from $ \ (member, person, sharer) -> do
             where_ $
-                member ^. GroupMemberGroup  ==. val gid            &&.
+                member ^. GroupMemberGroup  E.==. val gid            &&.
-                member ^. GroupMemberPerson ==. person ^. PersonId &&.
+                member ^. GroupMemberPerson E.==. person ^. PersonId &&.
-                person ^. PersonIdent       ==. sharer ^. SharerId
+                person ^. PersonIdent       E.==. sharer ^. SharerId
             orderBy
                 [ asc $ member ^. GroupMemberRole
                 , asc $ sharer ^. SharerIdent
@@ -163,10 +166,49 @@ getGroupMemberNewR shar = do
     defaultLayout $(widgetFile "group/member/new")
 
 getGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
-getGroupMemberR grp memb = error "Not implemented"
+getGroupMemberR grp memb = do
+    member <- runDB $ do
+        gid <- do
+            Entity s _ <- getBy404 $ UniqueSharer grp
+            Entity g _ <- getBy404 $ UniqueGroup s
+            return g
+        pid <- do
+            Entity s _ <- getBy404 $ UniqueSharer memb
+            Entity p _ <- getBy404 $ UniquePersonIdent s
+            return p
+        Entity _mid m <- getBy404 $ UniqueGroupMember pid gid
+        return m
+    defaultLayout $(widgetFile "group/member/one")
 
 deleteGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
-deleteGroupMemberR grp memb = error "Not implemented"
+deleteGroupMemberR grp memb = do
+    succ <- runDB $ do
+        gid <- do
+            Entity s _ <- getBy404 $ UniqueSharer grp
+            Entity g _ <- getBy404 $ UniqueGroup s
+            return g
+        pid <- do
+            Entity s _ <- getBy404 $ UniqueSharer memb
+            Entity p _ <- getBy404 $ UniquePersonIdent s
+            return p
+        mm <-
+            selectFirst
+                [ GroupMemberGroup  ==. gid
+                , GroupMemberPerson !=. pid
+                , GroupMemberRole   ==. GRAdmin
+                ]
+                []
+        case mm of
+            Nothing -> return False
+            Just _  -> do
+                Entity mid _m <- getBy404 $ UniqueGroupMember pid gid
+                delete mid
+                return True
+    setMessage $
+        if succ
+            then "Group member removed."
+            else "Can’t leave a group without an admin."
+    redirect $ GroupMembersR grp
 
 postGroupMemberR :: ShrIdent -> ShrIdent -> Handler Html
 postGroupMemberR grp memb = do

templates/group/member/one.hamlet

@@ -0,0 +1,19 @@
+$# 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/>.
+
+<p>
+  Role: #{show $ groupMemberRole member}.
+
+<p>
+  Joined on #{showDate $ groupMemberJoined member}.