From 84c12b5fc7c875940900c2c38cf59b09c0d63fab Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 29 Jul 2019 17:10:38 +0200 Subject: [PATCH] feat(notification triggers): redesign interface Fixes #410 --- messages/uniworx/de.msg | 8 +++- src/Database/Esqueleto/Utils.hs | 10 +++++ src/Handler/Profile.hs | 73 +++++++++++++++++++++++++++++++-- src/Handler/Utils/Form.hs | 43 +++++++++++++++---- src/Model/Types/Mail.hs | 2 +- src/Utils/Form.hs | 6 ++- 6 files changed, 127 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c34fbc21b..833df71e9 100644 --- a/messages/uniworx/de.msg +++ b/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}" @@ -1336,4 +1342,4 @@ LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. -SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen \ No newline at end of file +SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f8a41ed37..5a032a6de 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 8afac65ce..7b2b5344d 100644 --- a/src/Handler/Profile.hs +++ b/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 - where - nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template) +notificationForm template = wFormToAForm $ do + mbUid <- liftHandlerT maybeAuthId + 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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e7c9895ec..d6c80900c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -855,16 +855,34 @@ boolField = Field -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 mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty +sectionedFuncForm :: forall k v m sec. + ( Finite k, Ord k + , MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX sec + , Ord sec + ) + => (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 diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 3f670b4fe..730de2c05 100644 --- a/src/Model/Types/Mail.hs +++ b/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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c0ac56f28..7431ff251 100644 --- a/src/Utils/Form.hs +++ b/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@, ... -- ---------------------------------------------