feat(notification triggers): redesign interface

Fixes #410

messages/uniworx/de.msg

@@ -737,6 +737,12 @@ NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Ü
 NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
 NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert
 
+NotificationTriggerKindAll: Für alle Benutzer
+NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
+NotificationTriggerKindCorrector: Für Korrektoren
+NotificationTriggerKindLecturer: Für Dozenten
+NotificationTriggerKindAdmin: Für Administratoren
+
 CorrCreate: Abgaben erstellen
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
 InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"

src/Database/Esqueleto/Utils.hs

@@ -14,6 +14,7 @@ module Database.Esqueleto.Utils
   , orderByList
   , orderByOrd, orderByEnum
   , lower, ciEq
+  , selectExists
   ) where
 
 
@@ -189,3 +190,12 @@ lower = E.unsafeSqlFunction "LOWER"
 
 ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
 ciEq a b = lower a E.==. lower b
+
+
+selectExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool
+selectExists query = do
+  res <- E.select . return . E.exists $ void query
+
+  case res of
+    [E.Value b] -> return b
+    _other      -> error "SELECT EXISTS ... returned zero or more than one rows"

src/Handler/Profile.hs

@@ -9,9 +9,11 @@ import Utils.Lens
 -- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
+import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 -- import           Database.Esqueleto      ((^.))
 
 
@@ -26,6 +28,14 @@ data SettingsForm = SettingsForm
       , stgNotificationSettings :: NotificationSettings
       }
 
+data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKCorrector | NTKLecturer | NTKAdmin
+  deriving (Eq, Ord, Enum, Bounded, Generic, Typeable)
+instance Universe NotificationTriggerKind
+instance Finite NotificationTriggerKind
+
+embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel
+
+
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
@@ -38,7 +48,7 @@ makeSettingForm template html = do
         <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
         <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
         <*  aformSection MsgFormBehaviour
-        <*> areq checkBoxField (fslI MsgDownloadFiles
+        <*> apopt checkBoxField (fslI MsgDownloadFiles
                                    & setTooltip MsgDownloadFilesTip
                                 ) (stgDownloadFiles <$> template)
         <*  aformSection MsgFormNotifications
@@ -76,9 +86,64 @@ makeSettingForm template html = do
 --     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
-notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
+notificationForm template = wFormToAForm $ do
-  where
+  mbUid <- liftHandlerT maybeAuthId
-    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
+  isAdmin <- hasReadAccessTo AdminR
+  
+  let
+    sectionIsHidden :: NotificationTriggerKind -> DB Bool
+    sectionIsHidden nt
+      | isAdmin
+      = return False
+      | Just uid <- mbUid
+      , NTKAdmin <- nt
+      = E.selectExists . E.from $ \userAdmin ->
+          E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKLecturer <- nt
+      = E.selectExists . E.from $ \userLecturer ->
+          E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKCorrector <- nt
+      = E.selectExists . E.from $ \sheetCorrector ->
+          E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKCourseParticipant <- nt
+      = E.selectExists . E.from $ \courseParticipant ->
+          E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
+      | otherwise
+      = return False
+  
+  ntHidden <- liftHandlerT . runDB
+            $ Set.fromList universeF
+            & Map.fromSet sectionIsHidden
+            & sequenceA
+            & fmap (!)
+  
+  let
+    nsForm nt
+      | maybe False ntHidden $ ntSection nt
+      = pure $ notificationAllowed def nt
+      | nt `elem` forcedTriggers
+      = aforced checkBoxField (fslI nt) (notificationAllowed def nt)
+      | otherwise
+      = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
+
+    ntSection = \case
+      NTSubmissionRatedGraded     -> Just NTKCourseParticipant
+      NTSubmissionRated           -> Just NTKCourseParticipant
+      NTSheetActive               -> Just NTKCourseParticipant
+      NTSheetSoonInactive         -> Just NTKCourseParticipant
+      NTSheetInactive             -> Just NTKLecturer
+      NTCorrectionsAssigned       -> Just NTKCorrector
+      NTCorrectionsNotDistributed -> Just NTKLecturer
+      NTUserRightsUpdate          -> Just NTKAll
+      NTUserAuthModeUpdate        -> Just NTKAll
+      -- _other                      -> Nothing
+
+    forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
+    
+  aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
 
 
 data ButtonResetTokens = BtnResetTokens

src/Handler/Utils/Form.hs

@@ -855,16 +855,34 @@ boolField = Field
 
 
 
-funcForm :: forall k v m.
+sectionedFuncForm  :: forall k v m sec.
-            ( Finite k, Ord k
+                      ( Finite k, Ord k
-            , MonadHandler m
+                      , MonadHandler m
-            , HandlerSite m ~ UniWorX
+                      , HandlerSite m ~ UniWorX
-            )
+                      , RenderMessage UniWorX sec
-         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+                      , Ord sec
-funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
+                      )
+                   => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
   where
     funcForm' :: AForm m (k -> v)
-    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
+    funcForm' = Set.fromList universeF
+              & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
+              & fmap (Map.fromSet mkForm)
+              & fmap sequenceA
+              & Map.foldrWithKey accSections (pure Map.empty)
+              & fmap (!)
+    accSections mSection optsForm acc = wFormToAForm $ do
+      (res, fs) <- wFormFields $ aFormToWForm optsForm
+      if
+        | not $ null fs
+        , Just section <- mSection
+          -> wformSection section
+        | otherwise
+          -> return ()
+      lift $ tell fs
+      aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
+  
     funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
     funcFieldView (res, fvInput) = do
       mr <- getMessageRender
@@ -879,6 +897,15 @@ funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAF
     -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
+funcForm :: forall k v m.
+            ( Finite k, Ord k
+            , MonadHandler m
+            , HandlerSite m ~ UniWorX
+            )
+         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
+
+
 
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED

src/Model/Types/Mail.hs

@@ -55,7 +55,7 @@ newtype NotificationSettings = NotificationSettings { notificationAllowed :: Not
 instance Default NotificationSettings where
   def = NotificationSettings $ \case
     NTSubmissionRatedGraded -> True
-    NTSubmissionRated -> False
+    NTSubmissionRated -> True
     NTSheetActive -> True
     NTSheetSoonInactive -> False
     NTSheetInactive -> True

src/Utils/Form.hs

@@ -25,7 +25,7 @@ import qualified Data.Set as Set
 
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Writer.Class (MonadWriter(..), censor)
 import Control.Monad.State.Class (MonadState(..))
 import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
@@ -920,6 +920,10 @@ infixl 4 `fmapAForm`
 fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
 fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
 
+wFormFields :: Monad m => WForm m a -> WForm m (a, [FieldView (HandlerSite m)])
+-- ^ Suppress side effect of appending `FieldView`s and instead add them to the result
+wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (const mempty) . listen)
+
 ---------------------------------------------
 -- Special variants of @mopt@, @mreq@, ... --
 ---------------------------------------------