From ce2dbd74145807667f024325976ab3328be248cb Mon Sep 17 00:00:00 2001
From: Andor Penzes <andor.penzes@gmail.com>
Date: Fri, 24 Jun 2016 15:54:18 +0200
Subject: [PATCH] Separate CanDelegate, CanDelegateInClass and
 CanDelegateInSchool.

---
 src/Access.hs             | 16 +++++++++++++---
 src/Frontend/Core.hs      | 12 ++++++++++--
 src/Frontend/Page/User.hs |  2 +-
 3 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/src/Access.hs b/src/Access.hs
index fdec3cc0..eb216529 100644
--- a/src/Access.hs
+++ b/src/Access.hs
@@ -85,7 +85,6 @@ data Capability
     = CanView
     | CanLike
     | CanVote
-    | CanDelegate
     | CanComment
     | CanVoteComment
     | CanJudge  -- also can add jury statement
@@ -106,6 +105,9 @@ data Capability
     | CanCreateIdea
     -- User
     | CanCreateTopic
+    | CanDelegate
+    | CanDelegateInClass
+    | CanDelegateInSchool
     | CanEditUser
   deriving (Enum, Bounded, Eq, Ord, Show, Read, Generic)
 
@@ -160,14 +162,22 @@ capabilities :: CapCtx -> [Capability]
 capabilities (CapCtx u ms mp mi mc mup mdt)
     | not . checkSpace ms $ rs ^. each . roleScope = []
     | otherwise = mconcat . mconcat $
-    [ [ userCapabilities r                   | r <- rs ]
+    [ userCapabilities'
     , [ ideaCapabilities (u ^. _Id) r i p    | r <- rs, i <- l mi, p <- l mp ]
     , [ commentCapabilities (u ^. _Id) r c p | r <- rs, c <- l mc, p <- l mp ]
     , [ topicCapabilities p r                | r <- rs, p <- l mp ]
     , [ [CanEditUser]                        | up <- l mup, isOwnProfile u up ]
-    , [ [CanDelegate]                        | dtu <- l mdt, haveCommonSchoolClass u dtu ]
+    , [ [CanDelegateInClass]                 | dtu <- l mdt, haveCommonSchoolClass u dtu, canDelegateToUser]
+    , [ [CanDelegateInSchool]                | canDelegateToUser ]
     ]
   where
+    userCapabilities' = userCapabilities <$> rs
+    canDelegateToUser =
+        maybe
+            False
+            (\dtu -> CanDelegate `elem` concat userCapabilities'
+                     && CanDelegate `elem` (userCapabilities =<< (dtu ^.. userRoles)))
+            mdt
     rs = u ^.. userRoles
     l  = maybeToList
 
diff --git a/src/Frontend/Core.hs b/src/Frontend/Core.hs
index 750174f2..57a2a12d 100644
--- a/src/Frontend/Core.hs
+++ b/src/Frontend/Core.hs
@@ -437,6 +437,8 @@ instance Page (NeedCap 'CanEditAndDeleteIdea)   where isAuthorized = needCap Can
 instance Page (NeedCap 'CanVote)                where isAuthorized = needCap CanVote
 instance Page (NeedCap 'CanMarkWinner)          where isAuthorized = needCap CanMarkWinner
 instance Page (NeedCap 'CanDelegate)            where isAuthorized = needCap CanDelegate
+instance Page (NeedCap 'CanDelegateInSchool)    where isAuthorized = needCap CanDelegateInSchool
+instance Page (NeedCap 'CanDelegateInClass)     where isAuthorized = needCap CanDelegateInClass
 instance Page (NeedCap 'CanPhaseForwardTopic)   where isAuthorized = needCap CanPhaseForwardTopic
 instance Page (NeedCap 'CanPhaseBackwardTopic)  where isAuthorized = needCap CanPhaseBackwardTopic
 
@@ -444,10 +446,16 @@ instance Page NeedAdmin where isAuthorized = adminPage
 
 -- FIXME: move this to the rest of the delegation logic?  (where's that?)
 instance Page DelegateTo where
-    isAuthorized = authNeedCaps [CanDelegate] delegateToCapCtx
+    isAuthorized =
+        authNeedCapsAnyOf
+            [CanDelegateInClass, CanDelegateInSchool, CanDelegate]
+            delegateToCapCtx
 
 instance Page WithdrawDelegationFrom where
-    isAuthorized = authNeedCaps [CanDelegate] withdrawDelegationFromCapCtx
+    isAuthorized =
+        authNeedCapsAnyOf
+            [CanDelegateInClass, CanDelegateInSchool, CanDelegate]
+            withdrawDelegationFromCapCtx
 
 formPageHandler
     :: Applicative m
diff --git a/src/Frontend/Page/User.hs b/src/Frontend/Page/User.hs
index c7e1b6c8..b7e7909d 100644
--- a/src/Frontend/Page/User.hs
+++ b/src/Frontend/Page/User.hs
@@ -203,7 +203,7 @@ userHeaderDiv ctx (Right (user, delegations)) =
 
         div_ [class_ "heroic-btn-group"] $ do
             let caps = capabilities ctx
-            when (CanDelegate `elem` caps) $ do
+            when (CanDelegateInClass `elem` caps || CanDelegateInSchool `elem` caps) $ do
                 delegationButtons ctx user delegations
             btn (U.reportUser user) "melden"
             when (CanEditUser `elem` caps) $ do