Gregor Kleen
parent
9f0a91f0dd
commit
84c12b5fc7
@ -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
|
||||
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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@, ... --
|
||||
---------------------------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user