Separate CanDelegate, CanDelegateInClass and CanDelegateInSchool.

liqd · Jun 24, 2016 · ce2dbd7 · ce2dbd7
1 parent 421b76e
commit ce2dbd7
Show file tree

Hide file tree

Showing 3 changed files with 24 additions and 6 deletions.
diff --git 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
@@ -437,17 +437,25 @@ 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
 
 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
@@ -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