Merge branch 'fradrive/jost' into 'master'

add comm center for email/letter notification overview

Closes #171, #150, #148, #149, and #173

See merge request fradrive/fradrive!36

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -70,6 +70,10 @@ CourseInvalidInput: Eingaben bitte korrigieren.
 CourseEditTitle: Kursart editieren/anlegen
 CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
 CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
+CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
+CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
+CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
+CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
 CourseLecturer: Kursverwalter:in
 MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme
 CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName}

messages/uniworx/categories/courses/courses/en-eu.msg

@@ -70,8 +70,12 @@ CourseInvalidInput: Invalid input
 CourseEditTitle: Edit/Create course
 CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} 
 CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school.
+CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons.
+CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}.
+CourseEditQualificationFailExists: This qualification is already associated
+CourseEditQualificationFailOrder: This sort order priority is used already
 CourseLecturer: Course administrator
-MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
+MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
 CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName}
 CourseParticipantInviteExplanation: You were invited to be a participant of a course.
 CourseParticipantInviteField: Email addresses to invite

messages/uniworx/categories/firm/de-de-formal.msg

@@ -19,7 +19,7 @@ FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
 FirmActAddSupervisors: Ansprechpartner hinzufügen
 FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
-RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
+RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
 FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.

messages/uniworx/categories/firm/en-eu.msg

@@ -19,7 +19,7 @@ FirmActResetMutualSupervision: Supervisors supervise each other
 FirmActAddSupervisors: Add supervisors
 FirmActAddSupersEmpty: No supervisors added
 FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
-RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
+RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
 FirmActChangeContactUser: Change contact data for all company associates
 FirmActChangeContactFirm: Change company contact data
 FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.

messages/uniworx/categories/print/de-de-formal.msg

@@ -26,4 +26,7 @@ PrintPDF !ident-ok: PDF
 PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
 PrintLmsUser: E‑Learning Id
 PrintJobs: Druckaufräge
-PrintLetterType: Brieftypkürzel
+PrintLetterType: Brieftypkürzel
+
+MCActDummy: Platzhalter
+CCActDummy: Platzhalter

messages/uniworx/categories/print/en-eu.msg

@@ -26,4 +26,7 @@ PrintPDF: PDF
 PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
 PrintLmsUser: E‑learning id
 PrintJobs: Print jobs
-PrintLetterType: Letter type shorthand
+PrintLetterType: Letter type shorthand
+
+MCActDummy: Placeholder
+CCActDummy: Placeholder

messages/uniworx/categories/user/de-de-formal.msg

@@ -114,4 +114,5 @@ UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow us
 UserCompanyReason: Begründung der Firmenassoziation
 UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
 UserSupervisorReason: Begründung Ansprechpartner
-UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer

messages/uniworx/categories/user/en-eu.msg

@@ -114,4 +114,5 @@ UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "prev
 UserCompanyReason: Reason for company association
 UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
 UserSupervisorReason: Reason for supervision
-UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+AdminUserAllNotifications: All notification sent to this user

messages/uniworx/misc/de-de-formal.msg

@@ -29,4 +29,5 @@ PaginationSize: Einträge pro Seite
 PaginationPage: Angzeigte Seite
 PaginationError: Paginierung Parameter dürfen nicht negativ sein
 
-NullDeletes: Zum Löschen NULL eingeben.
+NullDeletes: Zum Löschen NULL eingeben.
+SortPriority: Sortierungspriorität

messages/uniworx/misc/en-eu.msg

@@ -29,4 +29,5 @@ PaginationSize: Rows per Page
 PaginationPage: Page to show
 PaginationError: Pagination parameter must not be negative
 
-NullDeletes:  Enter NULL to delete.
+NullDeletes:  Enter NULL to delete.
+SortPriority: Sort order priority

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -143,12 +143,17 @@ MenuSap: SAP Schnittstelle
 MenuAvs: AVS Schnittstelle
 MenuAvsSynchError: AVS Problemübersicht
 MenuLdap: LDAP Schnittstelle
-MenuApc: Druckerei
+MenuApc: Druck
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
 MenuPrintLog: LPR Schnittstelle
 MenuPrintAck: Druckbestätigung
 
+MenuCommCenter: Benachrichtigungen
+MenuMailCenter: E‑Mails
+MenuMailHtml !ident-ok: Html
+MenuMailPlain !ident-ok: Text
+
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
 

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -143,12 +143,17 @@ MenuSap: SAP Interface
 MenuAvs: AVS Interface
 MenuAvsSynchError: AVS Problem Overview
 MenuLdap: LDAP Interface
-MenuApc: Printing
+MenuApc: Print
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
 MenuPrintLog: LPR Interface
 MenuPrintAck: Acknowledge Printing
 
+MenuCommCenter: Notifications
+MenuMailCenter: Email
+MenuMailHtml: Html
+MenuMailPlain: Text
+
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)
 

models/lms.model

@@ -14,7 +14,7 @@ Qualification
   refreshReminder     CalendarDiffDays Maybe    -- send a second notification about renewal within this number of month/days before expiry
   elearningStart      Bool                      -- automatically schedule e-refresher
   elearningRenews     Bool default=true         -- successful e-learing automatically increases validity automatically by validDuration
-  elearningLimit      Int Maybe defualt=5       -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
+  elearningLimit      Int Maybe                 -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
   lmsReuses           QualificationId Maybe     -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
   expiryNotification  Bool default=true         -- should expiryNotification be generated for this qualification?
   avsLicence          AvsLicence Maybe          -- if set, valid QualificationUsers are synchronized to AVS as a driving licence

routes

@@ -77,6 +77,11 @@
 /admin/problems/avs  					ProblemAvsSynchR 		 GET POST
 /admin/problems/avs/errors		ProblemAvsErrorR 		 GET
 
+/comm                                 CommCenterR     GET 
+/comm/email                           MailCenterR     GET POST
+/comm/email/html/#CryptoUUIDSentMail  MailHtmlR       GET
+/comm/email/plain/#CryptoUUIDSentMail MailPlainR      GET
+
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer
 /print/acknowledge/direct             PrintAckDirectR GET POST  !system-printer

src/Application.hs

@@ -157,6 +157,8 @@ import Handler.Upload
 import Handler.Qualification
 import Handler.LMS
 import Handler.SAP
+import Handler.CommCenter
+import Handler.MailCenter
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
@@ -352,15 +354,15 @@ makeFoundation appSettings''@AppSettings{..} = do
           handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
         return conn
 
-      appAvsQuery <- case appAvsConf of 
+      appAvsQuery <- case appAvsConf of
         Nothing -> do
           $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
           return Nothing
-          -- error "AvsConfig is empty, i.e. invalid AVS configuration settings."          
+          -- error "AvsConfig is empty, i.e. invalid AVS configuration settings."
-          
+
-        Just avsConf -> do          
+        Just avsConf -> do
           manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
-          let avsServer = BaseUrl 
+          let avsServer = BaseUrl
                             { baseUrlScheme = Https
                             , baseUrlHost = avsHost avsConf
                             , baseUrlPort = avsPort avsConf
@@ -657,7 +659,7 @@ appMain = runResourceT $ do
                    notifyWatchdog = forever' Nothing $ \pResults -> do
                      let delay = floor $ wInterval % 4
                      d <- liftIO $ newDelay delay
- 
+
                      $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
                      mResults <- atomically $ asum
                        [ pResults <$ waitDelay d

src/CryptoID.hs

@@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
              , ''MaterialFileId
              , ''PrintJobId
              , ''QualificationId
+             , ''SentMailId
              ]
 
 decCryptoIDKeySize

src/Database/Esqueleto/Utils.hs

@@ -48,6 +48,7 @@ module Database.Esqueleto.Utils
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
+  , str2text, str2text'
   , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
@@ -328,7 +329,7 @@ mkExactFilterLastWith :: (PersistField b)
                       -> Last a                        -- ^ needle
                       -> E.SqlExpr (E.Value Bool)
 mkExactFilterLastWith cast lenslike row criterias
-  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)  
+  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
   | otherwise = true
 
 -- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
@@ -409,7 +410,7 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
   | Set.null compulsories = cond_optional
   | Set.null alternatives = cond_compulsory
   | otherwise             = cond_compulsory E.&&. cond_optional
-  where    
+  where
     (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
     cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
     cond_optional   = any (hasInfix (lenslike row) . E.val . cast) alternatives
@@ -516,7 +517,7 @@ selectExists query = do
     _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
 selectNotExists = fmap not . selectExists
 
-filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) 
+filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
              => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
 filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
   ent <- Ex.from Ex.table
@@ -655,7 +656,7 @@ infixl 8 ->.
 
 infixl 8 ->>.
 
-(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) 
+(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
 (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
 
 infixl 8 ->>>.
@@ -682,7 +683,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue
 -- | distinct version of `Database.Esqueleto.subSelectCount`
 subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
 subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
-  
+
 -- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
 -- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
 
@@ -707,6 +708,13 @@ selectCountDistinct q = do
 selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
 selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 
+-- | convert something that is like a text to text
+str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
+str2text = E.unsafeSqlCastAs "text"
+
+str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
+str2text' = E.unsafeSqlCastAs "text"
+
 -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
 num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
 num2text = E.unsafeSqlCastAs "text"
@@ -726,9 +734,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
 dayMaybe = E.unsafeSqlCastAs "date"
 
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
--- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
-  where 
+  where
     singleQuote     = Text.Builder.singleton '\''
     wrapSqlString b = singleQuote <> b <> singleQuote
 
@@ -775,12 +783,12 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
 
 
 -- Suspected to cause trouble. Needs more testing!
--- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) 
+-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
 --               => record -> ReaderT backend m ()
 -- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
 
 truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
                   => proxy record -> ReaderT backend m ()
-truncateTable tbl = 
+truncateTable tbl =
   let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
   in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

src/Foundation/Navigation.hs

@@ -129,7 +129,12 @@ breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAll
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
 breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
 
-breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
+breadcrumb CommCenterR      = i18nCrumb MsgMenuCommCenter       Nothing
+breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter     $ Just CommCenterR
+breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
+breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
+
+breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc            $ Just CommCenterR
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
@@ -1225,7 +1230,7 @@ pageActions (AdminUserR cID) = return
   , NavPageActionPrimary
     { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID
     , navChildren = []
-    }  
+    }
   , NavPageActionPrimary
     { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID
     , navChildren = []
@@ -1461,7 +1466,7 @@ pageActions (ForProfileDataR cID) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
     , navChildren = []
-    }  
+    }
   ]
 pageActions TermShowR = do
   participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
@@ -2477,6 +2482,30 @@ pageActions PrintCenterR = do
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
   return $ manualSend : printLog : printAck : take 9 dayLinks
 
+pageActions CommCenterR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailCenter MailCenterR
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgMenuApc PrintCenterR
+    , navChildren = []
+    }
+  ]
+
+pageActions (MailHtmlR smid) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+    , navChildren = []
+    }
+  ]
+pageActions (MailPlainR smid) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+    , navChildren = []
+    }
+  ]
+
 pageActions AdminCrontabR = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuAdminJobs AdminJobsR

src/Foundation/Yesod/Auth.hs

@@ -107,7 +107,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "auth" $ tshow Creds{..}  
+  $logDebugS "auth" $ tshow Creds{..}
   ldapPool' <- getsYesod $ view _appLdapPool
 
   flip catches excHandlers $ case ldapPool' of
@@ -153,9 +153,9 @@ _upsertCampusUserMode mMode cs@Creds{..}
 
     defaultOther = apHash
 
-ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
+ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
-ldapLookupAndUpsert ident = 
+ldapLookupAndUpsert ident =
-  getsYesod (view _appLdapPool) >>= \case 
+  getsYesod (view _appLdapPool) >>= \case
     Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
     Just ldapPool ->
       campusUser'' ldapPool campusUserFailoverMode ident >>= \case
@@ -188,15 +188,15 @@ upsertCampusUser upsertMode ldapData = do
   user@(Entity userId userRec) <- case oldUsers of
     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
     _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName (newUser ^. _userTitle) 
+  unless (validDisplayName (newUser ^. _userTitle)
                            (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname) 
+                           (newUser ^. _userSurname)
                            (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
+    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]  -- update invalid display names only
-  when (validEmail' (userRec ^. _userEmail)) $ do 
+  when (validEmail' (userRec ^. _userEmail)) $ do                         -- RECALL: userRec already contains basic updates
     let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
               ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-    unless (null emUps) $ update userId emUps
+    update userId emUps -- update already checks whether list is empty
     -- Attempt to update ident, too:
     unless (validEmail' (userRec ^. _userIdent)) $
       void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
@@ -227,7 +227,7 @@ decodeUserTest mbIdent ldapData = do
 
 
 decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
-decodeUser now UserDefaultConf{..} upsertMode ldapData = do    
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     let
       userTelephone             = decodeLdap ldapUserTelephone <&> canonicalPhone
       userMobile                = decodeLdap ldapUserMobile    <&> canonicalPhone
@@ -266,7 +266,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       --      -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
-        
+
     userLdapPrimaryKey <- if
       | [bs] <- ldapMap !!! ldapPrimaryKey
       , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@@ -305,13 +305,13 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userPrefersPostal           = userDefaultPrefersPostal
         , ..
         }
-      userUpdate =  
+      userUpdate =
         [ UserLastAuthentication      =. Just now  | isLogin ] ++
         [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
         [
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
           UserFirstName               =. userFirstName
-        , UserSurname                 =. userSurname                    
+        , UserSurname                 =. userSurname
         , UserLastLdapSynchronisation =. Just now
         , UserLdapPrimaryKey          =. userLdapPrimaryKey
         , UserMobile                  =. userMobile

src/Handler/Admin/Avs.hs

@@ -59,7 +59,7 @@ instance Finite ButtonAvsTest
 nullaryPathPiece ''ButtonAvsTest camelToPathPiece
 
 instance Button UniWorX ButtonAvsTest where
-  btnLabel    BtnCheckLicences = "Check all licences"       -- could be msg
+  btnLabel    BtnCheckLicences = "Show all licence difference to current AVS"       -- could be msg
   -- btnLabel    BtnSynchLicences = "Synchronize all licences" -- could be msg
   btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
   -- btnClasses  BtnSynchLicences = [BCIsButton, BCDanger]
@@ -270,7 +270,7 @@ postAdminAvsR = do
     Nothing -> return Nothing
     (Just BtnCheckLicences) -> do
       res <- try $ do
-        allLicences <- avsQuery AvsQueryGetAllLicences
+        allLicences <- avsQueryNoCache AvsQueryGetAllLicences
         computeDifferingLicences allLicences
       case res of
         (Right diffs) -> do
@@ -531,11 +531,12 @@ instance HasUser LicenceTableData where
 mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
 mkLicenceTable apidStatus dbtIdent aLic apids = do
   currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
-  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
+  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
   now <- liftIO getCurrentTime
 
   let nowaday = utctDay now
       avsQids = entityKey <$> avsQualifications
+      qualOpts = pure $ qualificationsOptionList avsQualifications
       -- fltrLic qual = if
       --   | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)         -- could be R, F, both or none at all, but has licence in AVS
       --   | otherwise            -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
@@ -614,14 +615,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
         ]
 
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
       aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
 
       -- Block identical to Handler/Qualifications TODO: refactor
@@ -647,12 +640,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
           [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
           , if aLic == AvsNoLicence
               then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason) Nothing
                     <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)       (fslI MsgQualificationBlockNotify) (Just False)
 
               else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason) Nothing
                     <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
                     <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing

src/Handler/CommCenter.hs

@@ -0,0 +1,172 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+-- TODO: remove these above
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.CommCenter
+  ( getCommCenterR
+  ) where
+
+import Import
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Aeson  as Aeson
+-- import qualified Data.Text as Text
+
+-- import Database.Persist.Sql (updateWhereCount)
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+-- import Utils.Print
+
+import Handler.Utils
+-- import Handler.Utils.Csv
+-- import qualified Data.Csv as Csv
+-- import qualified Data.CaseInsensitive as CI
+
+-- import Jobs.Queue
+import qualified Data.Aeson as Aeson
+
+import Text.Blaze.Html (preEscapedToHtml)
+-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
+-- import Text.Blaze.Html.Renderer.String (renderHtml)
+-- import Data.Text (Text)
+
+
+import Data.Text.Lens (packed)
+-- import qualified Data.Text.Lazy as LT
+-- import qualified Data.Text.Lazy.Encoding as LT
+import qualified Data.ByteString.Lazy as LB
+
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe CCTableAction
+instance Finite CCTableAction
+nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''CCTableAction id
+
+data CCTableActionData  = CCActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
+type CCTableExpr =
+  (                   (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
+    `E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
+  )
+
+queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
+
+queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
+queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
+
+queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
+
+queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
+queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
+
+type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
+
+resultRecipientMail :: Traversal' CCTableData (Entity User)
+resultRecipientMail = _dbrOutput . _1 . _Just
+
+resultMail :: Traversal' CCTableData (Entity SentMail)
+resultMail = _dbrOutput . _2 . _Just
+
+resultRecipientPrint :: Traversal' CCTableData (Entity User)
+resultRecipientPrint = _dbrOutput . _3 . _Just
+
+resultPrint :: Traversal' CCTableData (Entity PrintJob)
+resultPrint = _dbrOutput . _4 . _Just
+
+
+mkCCTable :: DB (Any, Widget)
+mkCCTable = do
+  let
+    dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
+    dbtSQLQuery  ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
+      EL.on $ recipientMail  E.?. UserId E.==. E.joinV (mail     E.?. SentMailRecipient)
+      EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
+      -- EL.on $ recipientMail  E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
+      EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
+      -- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed
+      -- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
+      return (recipientMail,  mail, recipientPrint, printJob)
+    -- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
+    dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
+
+    dbtProj = dbtProjId
+    dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
+      [ sortable (Just "date")      (i18nCell MsgPrintJobCreated)       $ \row ->
+          let tprint  = row ^? resultPrint  . _entityVal . _printJobCreated
+              tmail   = row ^? resultMail   . _entityVal . _sentMailSentAt
+          in maybeCell (tprint <|> tmail) dateTimeCell
+      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \row ->
+          let uprint = row ^? resultRecipientPrint
+              umail  = row ^? resultRecipientMail
+          in  maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
+      , sortable Nothing (i18nCell MsgCommBody) $ \row -> if
+          | (Just k) <- row ^? resultPrint . _entityKey
+            -> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
+          | (Just k) <- row ^? resultMail  . _entityKey
+            -> anchorCellM (MailHtmlR      <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
+          | otherwise
+            -> mempty
+      , sortable Nothing (i18nCell MsgCommSubject) $ \row ->
+          let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
+              msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
+          in maybeCell (tsubject <|> msubject) textCell
+      ]
+    dbtSorting = mconcat
+      [ singletonMap "date"       $ SortColumn  $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
+      , singletonMap "recipient"  $ SortColumns $ \row ->
+          [ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname    , queryRecipientMail row E.?. UserSurname    ]
+          , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
+          ]
+      ]
+    dbtFilter = mconcat
+      [ single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
+      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
+                                                     ,E.str2text' $ queryMail  row E.?. SentMailHeaders  ])
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "comms"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = def
+    psValidator = def & defaultSorting [SortDescBy "date"]
+  dbTable psValidator DBTable{..}
+
+getCommCenterR :: Handler Html
+getCommCenterR = do
+  (_, ccTable) <- runDB mkCCTable
+  siteLayoutMsg MsgMenuMailCenter $ do
+    setTitleI MsgMenuMailCenter
+    $(widgetFile "comm-center")
+

src/Handler/Course/Edit.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -46,12 +46,13 @@ data CourseForm = CourseForm
         , cfRegTo        :: Maybe UTCTime
         , cfDeRegUntil   :: Maybe UTCTime
         , cfLecturers    :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        , cfQualis       :: [(QualificationId, Int)]
         }
 
 makeLenses_ ''CourseForm
 
-courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm
     { cfCourseId            = Just cid
     , cfName                = courseName
     , cfDesc                = courseDescription
@@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     , cfDeRegUntil          = courseDeregisterUntil
     , cfLecturers           = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                            ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
+    -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150
+    , cfQualis              = [ (courseQualificationQualification, courseQualificationSortOrder)
+                              | CourseQualification{..} <- qualis, courseQualificationCourse == cid ]
     }
 
 
@@ -81,17 +85,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     MsgRenderer mr <- getMsgRenderer
 
     uid <- liftHandler requireAuthId
-    (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
+    (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do
-      lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
+      lecturerSchools   <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
-      protoAdminSchools  <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
+      protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]]    [] -- default rights
-      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
+      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now
       oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
-      return (lecturerSchools, adminSchools, oldSchool)
+      let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
-    let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+          userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
+      elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
+      return (userSchools, qualificationsOptionList elegibleQualifications)
 
     (termsField, userTerms) <- liftHandler $ case template of
       -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
-      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
+      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c
           _courseOld@Course{..} <- runDB $ get404 cid
           mayEditTerm <- isAuthorized TermEditR True
           mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@@ -102,51 +108,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
               -> return (termsSetField [cfTerm cform], [cfTerm cform])
       _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
 
-    let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+    let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
-        miAdd _ _ _ nudge btn = Just $ \csrf -> do
-          (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
-          let addRes'' = addRes <&> \newDat oldDat -> if
-                | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
-                , not $ Set.null existing
-                  -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
-                | otherwise
-                  -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
-              addView' = $(widgetFile "course/lecturerMassInput/add")
-          return (addRes'', addView')
-
-        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
-          usr <- liftHandler . runDB $ get404 lid
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-          return (Just <$> lrwRes,lrwView')
-        miCell _ (Left lEmail) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-          invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
-          return (lrwRes,lrwView')
-
-        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-                 -> ListPosition -- ^ Coordinate to delete
-                 -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
-        miDelete = miDeleteList
-
-        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
-        miAddEmpty _ _ _ = Set.empty
-
-        miLayout :: ListLength
-                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-                 -> Map ListPosition Widget -- ^ Cell widgets
-                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-                 -> Widget
-        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
-
-        miIdent :: Text
-        miIdent = "lecturers"
-
-
-        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
@@ -163,6 +125,79 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
             unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
+            miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+            miAdd _ _ _ nudge btn = Just $ \csrf -> do
+              (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
+              let addRes'' = addRes <&> \newDat oldDat -> if
+                    | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
+                    , not $ Set.null existing
+                      -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
+                    | otherwise
+                      -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
+                  addView' = $(widgetFile "course/lecturerMassInput/add")
+              return (addRes'', addView')
+
+            miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
+            miCell _ (Right lid) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
+              usr <- liftHandler . runDB $ get404 lid
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
+              return (Just <$> lrwRes,lrwView')
+            miCell _ (Left lEmail) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+              invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
+              return (lrwRes,lrwView')
+
+            miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
+                    -> ListPosition -- ^ Coordinate to delete
+                    -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
+            miDelete = miDeleteList
+
+            miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+            miAddEmpty _ _ _ = Set.empty
+
+            miLayout :: ListLength
+                    -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                    -> Map ListPosition Widget -- ^ Cell widgets
+                    -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                    -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                    -> Widget
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
+            miIdent :: Text
+            miIdent = "lecturers"
+
+        qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications
+        qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False
+          where
+            miIdent :: Text
+            miIdent = "qualifications"
+
+            miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)])
+            miAdd  nudge submitView csrf = do
+              (formRes, formView) <- aCourseQualiForm nudge Nothing csrf
+              let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
+                    let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
+                        ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ]
+                        problems = qidBad ++ ordBad
+                    in if null problems
+                        then FormSuccess $ pure newDat
+                        else FormFailure problems
+              return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add"))
+
+            miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int)
+            miEdit nudge  = aCourseQualiForm nudge . Just
+
+            miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int)
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout")
+
+            aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int)
+            aCourseQualiForm nudge mTemplate csrf = do
+              (cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate)
+              (ordRes, ordView) <- mpreq     intField                                ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate)
+              return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form"))
+
     (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
         _allIOtherCases -> do
@@ -208,6 +243,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
       <*  aformSection MsgCourseFormSectionAdministration
       <*> lecturerForm
+      <*> qualificationsForm (cfQualis <$> template)
     return (result, widget)
 
 
@@ -227,6 +263,10 @@ validateCourse = do
   unless userAdmin $ do
     guardValidation MsgCourseUserMustBeLecturer
       $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
+  guardValidation MsgCourseEditQualificationFailExists
+    $ not $ hasDuplicates $ fst <$> cfQualis
+  guardValidation MsgCourseEditQualificationFailOrder
+    $ not $ hasDuplicates $ snd <$> cfQualis
 
   warnValidation MsgCourseShorthandTooLong
     $ length (CI.original cfShort) <= 10
@@ -280,8 +320,11 @@ getCourseNewR = do
           E.limit 1
           return course
       template <- case oldCourses of
-        (oldTemplate:_) ->
+        (oldTemplate:_) -> runDB $ do
-            let newTemplate = courseToForm oldTemplate mempty mempty in
+            mbLecs       <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+            mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey
+            mbQualis     <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+            let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
@@ -314,10 +357,11 @@ pgCEditR tid ssh csh = do
       mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
       mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
       mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey
-      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
+      mbQualis     <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
 
 
 -- | Course Creation and Editing
@@ -357,6 +401,7 @@ courseEditHandler miButtonAction mbCourseForm = do
               let (invites, adds) = partitionEithers $ cfLecturers res
               insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
               sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
+              void $ upsertCourseQualifications aid cid $ cfQualis res
               insert_ $ CourseEdit aid now cid
               memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
             return insertOkay
@@ -405,11 +450,9 @@ courseEditHandler miButtonAction mbCourseForm = do
                     let (invites, adds) = partitionEithers $ cfLecturers res
                     insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-
+                    void $ upsertCourseQualifications aid cid $ cfQualis res
                     insert_ $ CourseEdit aid now cid
-
                     memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
-
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
@@ -420,3 +463,35 @@ courseEditHandler miButtonAction mbCourseForm = do
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
         }
+
+-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool
+upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized
+upsertCourseQualifications uid cid qualis = do
+  let newQualis = Map.fromList qualis
+  oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
+                <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
+  -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
+  okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal)
+                <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
+  {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
+  $logErrorS "CourseQuali" $ "OLD  Course Qualifications:" <> tshow oldQualis
+  $logErrorS "CourseQuali" $ "NEW  Course Qualifications:" <> tshow newQualis
+  $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
+  -}
+  foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
+        Just so_new | so_new /= so_old
+                -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association
+        Nothing -> delete k                                          -- existing CourseQualifications may be removed,    regardless of school association
+        _       -> return ()
+  res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case
+        Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh}
+          | Set.member ssh okSchools ->
+              insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so}
+              $> All True
+          | otherwise -> do
+              addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh
+              pure $ All False
+        _ -> do
+              addMessageI Warning   MsgCourseEditQualificationFail
+              pure $ All False
+  pure $ getAll res

src/Handler/LMS.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 

src/Handler/MailCenter.hs

@@ -0,0 +1,277 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+-- TODO: remove these above
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.MailCenter
+  ( getMailCenterR, postMailCenterR
+  , getMailHtmlR
+  , getMailPlainR
+  ) where
+
+import Import
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Aeson  as Aeson
+-- import qualified Data.Text as Text
+
+-- import Database.Persist.Sql (updateWhereCount)
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+-- import Utils.Print
+
+import Handler.Utils
+-- import Handler.Utils.Csv
+-- import qualified Data.Csv as Csv
+-- import qualified Data.CaseInsensitive as CI
+
+-- import Jobs.Queue
+import qualified Data.Aeson as Aeson
+
+import Text.Blaze.Html (preEscapedToHtml)
+-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
+-- import Text.Blaze.Html.Renderer.String (renderHtml)
+-- import Data.Text (Text)
+
+
+-- import qualified Data.Text.Lazy as LT
+-- import qualified Data.Text.Lazy.Encoding as LT
+import qualified Data.ByteString.Lazy as LB
+
+import Data.Char as C
+
+import qualified Data.Text as T
+-- import qualified Data.Text.Encoding as TE
+-- import qualified Data.ByteString.Char8 as BS
+
+import Data.Bits
+-- import Data.Word
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe MCTableAction
+instance Finite MCTableAction
+nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''MCTableAction id
+
+data MCTableActionData  = MCActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+type MCTableExpr =
+  (                   E.SqlExpr (Entity SentMail)
+    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+  )
+
+queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
+queryMail = $(sqlLOJproj 2 1)
+
+
+queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
+queryRecipient = $(sqlLOJproj 2 2)
+
+
+type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
+
+resultMail :: Lens' MCTableData (Entity SentMail)
+resultMail = _dbrOutput . _1
+
+resultRecipient :: Traversal' MCTableData (Entity User)
+resultRecipient = _dbrOutput . _2 . _Just
+
+
+mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
+mkMCTable = do
+  let
+    dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
+    dbtSQLQuery  (mail `E.LeftOuterJoin` recipient) = do
+      EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
+      return (mail, recipient)
+    dbtRowKey = queryMail >>> (E.^. SentMailId)
+    dbtProj = dbtProjId
+    dbtColonnade = mconcat
+      [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
+        sortable (Just "sent")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
+      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
+          let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
+              linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
+          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
+      , sortable Nothing (i18nCell MsgMenuMailHtml)   $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
+      , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
+      ]
+    dbtSorting = mconcat
+      [ single ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
+      , single ("recipient" , sortUserNameBareM queryRecipient)
+      ]
+    dbtFilter = mconcat
+      [ single ("sent"      , FilterColumn . E.mkDayFilter                          $ views (to queryMail)        (E.^. SentMailSentAt))
+      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
+      , single ("subject"   , FilterColumn . E.mkContainsFilter                     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
+      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "sent-mail"
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+    dbtParams = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormNoSubmit
+      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+      -- , dbParamsFormSubmit = FormSubmit
+      -- , dbParamsFormAdditional
+      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+      --           acts = mconcat
+      --             [ singletonMap MCActDummy $ pure MCActDummyData
+      --             ]
+      --        in renderAForm FormStandard
+      --          $  (, mempty) . First . Just
+      --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
+                -> FormResult (      MCTableActionData, Set SentMailId)
+    postprocess inp = do
+        (First (Just act), jobMap) <- inp
+        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+        return (act, jobSet)
+    psValidator = def & defaultSorting [SortDescBy "sent"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+getMailCenterR,  postMailCenterR :: Handler Html
+getMailCenterR = postMailCenterR
+postMailCenterR = do
+  (mcRes, mcTable) <- runDB mkMCTable
+  formResult mcRes $ \case
+    (MCActDummyData, Set.toList -> _smIds) -> do
+      addMessageI Success MsgBoolIrrelevant
+      reloadKeepGetParams MailCenterR
+  siteLayoutMsg MsgMenuMailCenter $ do
+    setTitleI MsgMenuMailCenter
+    $(widgetFile "mail-center")
+
+
+getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
+getMailHtmlR  = handleMailShow [typeHtml,typePlain]
+
+getMailPlainR :: CryptoUUIDSentMail -> Handler Html
+getMailPlainR = handleMailShow [typePlain,typeHtml]
+
+handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
+handleMailShow prefTypes cusm = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDB $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  siteLayoutMsg MsgMenuMailCenter $ do
+    setTitleI MsgMenuMailCenter
+    let mcontent = getMailContent (sentMailContentContent cn)
+        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
+    [whamlet|
+      <section>
+        <dl .deflist>
+          <dt .deflist__dt>
+            _{MsgPrintJobCreated}
+          <dd .deflist__dd>
+            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
+          $maybe r <- getHeader "From"
+            <dt .deflist__dt>
+              _{MsgPrintSender}
+            <dd .deflist__dd>
+              #{decodeMime r}
+          $maybe r <- getHeader "To"
+            <dt .deflist__dt>
+              _{MsgPrintRecipient}
+            <dd .deflist__dd>
+              #{decodeMime r}
+          $maybe r <- getHeader "Subject"
+            <dt .deflist__dt>
+              _{MsgCommSubject}
+            <dd .deflist__dd>
+              #{decodeMime r}
+
+      <section>
+        $forall mc <- mcontent
+          $maybe pt <- selectAlternative prefTypes mc
+            <p>
+              ^{part2widget pt}
+    |]
+    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
+    -- ^{jsonWidget (sentMailContentContent cn)}
+
+
+selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
+selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
+  where
+    aux ts@(ct:_) (pt:ps)
+      | ct == partType pt = Just pt
+      | otherwise         = aux ts ps
+    aux (_:ts) []         = aux ts allAlts
+    aux []     (pt:_)     = Just pt
+    aux _      []         = Nothing
+
+disposition2widget :: Disposition -> Widget
+disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget  DefaultDisposition       = mempty
+
+part2widget :: Part -> Widget
+part2widget Part{partContent=NestedParts ps} =
+  [whamlet|
+    <section>
+      $forall p <- ps
+        ^{part2widget p}
+        <hr>
+    <hr>
+  |]
+part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+    [whamlet|
+      <section>
+        ^{disposition2widget dispo}
+        ^{showBody}
+      <hr>
+    |]
+  where
+    showBody
+      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
+      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | pt == decodeUtf8 typeJson  =
+          let jw :: Aeson.Value -> Widget = jsonWidget
+          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
+      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
+
+
+-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
+decodeMime :: Text -> Text
+decodeMime t = t
+-- decodeMime t
+--   | Just r <- T.stripPrefix "=?utf-8?Q?" t
+--     = T.replace "_" " " $ T.replace "?=" "" r  -- TODO: this only works in plain cases without special characters; e.g. umlauts are not handled correctly
+--   | otherwise
+--     = t

src/Handler/PrintCenter.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -20,9 +20,9 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Database.Persist.Sql (updateWhereCount)
-import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Experimental  as Ex     -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Legacy        as E      -- needed for dbTable using Esqueleto.Legacy
-import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Utils         as E
 import Database.Esqueleto.Utils.TH
 
 import Utils.Print
@@ -133,10 +133,10 @@ instance Finite PJTableAction
 nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''PJTableAction id
 
--- Not yet needed, since there is no additional data for now:
 data PJTableActionData  = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool }
   deriving (Eq, Ord, Read, Show, Generic)
 
+
 type PJTableExpr = (                  E.SqlExpr (Entity PrintJob)
                     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
                     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))

src/Handler/Profile.hs

@@ -31,9 +31,11 @@ import Utils.Print (validCmdArgument)
 import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import qualified Database.Esqueleto.Legacy as E
+import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Legacy as EL (on,from)
 import qualified Database.Esqueleto.Utils as E
--- import           Database.Esqueleto      ((^.))
+
 import qualified Data.Text as Text
 import Data.List (inits)
 
@@ -44,6 +46,9 @@ import Jobs
 import Foundation.Yesod.Auth (updateUserLanguage)
 
 
+{-# ANN module ("HLint: ignore Functor law" :: String) #-}
+
+
 data ExamOfficeSettings
   = ExamOfficeSettings
     { eosettingsGetSynced :: Bool
@@ -192,28 +197,28 @@ notificationForm template = wFormToAForm $ do
         -> return False
       NTKCourseParticipant
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \courseParticipant ->
+          -> fmap not . E.selectExists . EL.from $ \courseParticipant ->
                E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
                     E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
       NTKSubmissionUser
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \submissionUser ->
+          -> fmap not . E.selectExists . EL.from $ \submissionUser ->
                E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
       NTKExamParticipant
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \examRegistration ->
+          -> fmap not . E.selectExists . EL.from $ \examRegistration ->
                E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
       NTKCorrector
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \sheetCorrector ->
+          -> fmap not . E.selectExists . EL.from $ \sheetCorrector ->
                E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
       NTKCourseLecturer
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \lecturer ->
+          -> fmap not . E.selectExists . EL.from $ \lecturer ->
                E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
       NTKFunctionary f
         | Just uid <- mbUid
-          -> fmap not . E.selectExists . E.from $ \userFunction ->
+          -> fmap not . E.selectExists . EL.from $ \userFunction ->
                E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                     E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
       _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)
@@ -428,8 +433,8 @@ serveProfileR :: (UserId, User) -> Handler Html
 serveProfileR (uid, user@User{..}) = do
   currentRoute <- fromMaybe ProfileR <$> getCurrentRoute
   (userSchools, userExamOfficeLabels) <- runDB $ do
-    userSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
+    userSchools <- fmap (setOf $ folded . _Value) . E.select . EL.from $ \school -> do
-      E.where_ . E.exists . E.from $ \userSchool ->
+      E.where_ . E.exists . EL.from $ \userSchool ->
         E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
              E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
              E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
@@ -519,8 +524,8 @@ serveProfileR (uid, user@User{..}) = do
         oldExamLabels = userExamOfficeLabels
         newExamLabels = stgExamOfficeSettings & eosettingsLabels
       forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
-        E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
+        E.delete . EL.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
-        E.delete . E.from $ \examOfficeExamLabel         -> E.where_ $ examOfficeExamLabel         E.^. ExamOfficeExamLabelLabel         E.==. E.val eolid
+        E.delete . EL.from $ \examOfficeExamLabel         -> E.where_ $ examOfficeExamLabel         E.^. ExamOfficeExamLabelLabel         E.==. E.val eolid
         when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
           update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
         delete eolid
@@ -633,19 +638,19 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
   addressLinkdIcon <- messageTooltip <$> messageIconI Info IconLink MsgAddressIsLinkedTip
   (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
-  lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
+  lecture_corrector <- E.select $ E.distinct $ EL.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
-      E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+      EL.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
-      E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+      EL.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
       E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
       return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
-  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+  studies <- E.select $ EL.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-      E.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
+      EL.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
-      E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
+      EL.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       return  (studyfeat, studydegree, studyterms)
   companies <- wgtCompanies uid
-  -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  -- supervisors' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-  --     E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+  --     EL.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
   --     E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
   --     E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
   --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
@@ -653,8 +658,8 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
   --     supervisors = intersperse (text2widget ", ") $
   --       (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
   --     icnReroute = text2widget " " <> toWgt (icon IconReroute)
-  -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  -- supervisees' <- E.select $ EL.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
-  --     E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
+  --     EL.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
   --     E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
   --     return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
   -- let numSupervisees = length supervisees'
@@ -681,7 +686,7 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
   -- let examTable, ownTutorialTable, tutorialTable :: Widget
   --     examTable        = i18n MsgPersonalInfoExamAchievementsWip
   --     ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
-  --     tutorialTable    = i18n MsgPersonalInfoTutorialsWip
+  --     tutorialTable    = i18n MsgPersonalInfoTutorialsWip -- note that tutorials are linked in enrolledCoursesTable
 
   cID <- encrypt uid
   mCRoute <- getCurrentRoute
@@ -705,7 +710,7 @@ mkOwnedCoursesTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
-          E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+          EL.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
           E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
           return ( course E.^. CourseTerm
                  , course E.^. CourseSchool
@@ -747,18 +752,28 @@ mkOwnedCoursesTable =
 
 -- | Table listing all courses that the given user is enrolled in
 mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
-mkEnrolledCoursesTable =
+mkEnrolledCoursesTable uid = do
-  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
+  usrTuts <- E.select $ do
+    (tpar :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial
+                      `E.on` (\(tpar :& tut) -> tut E.^. TutorialId E.==. tpar E.^. TutorialParticipantTutorial)
+    E.where_ $ tpar E.^. TutorialParticipantUser E.==. E.val uid
+    E.orderBy [E.asc $ tut E.^. TutorialCourse, E.desc $ tut E.^. TutorialName] -- Data.Map.fromAscListWith reverses tutorials, hence E.desc
+    return (tut E.^. TutorialCourse, tut E.^. TutorialName)
+
+  let usrTutMap :: Map CourseId [TutorialName]
+      usrTutMap = Map.fromAscListWith (++) [(tcid, [tnm]) | (E.Value tcid, E.Value tnm) <- usrTuts]
+
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
                -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
       withType = id
 
       validator = def & defaultSorting [SortDescBy "time"]
 
-  in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
+  (_1 %~ getAny) <$> dbTableWidget validator
     DBTable
       { dbtIdent     = "courseMembership" :: Text
       , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
-          E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
+          EL.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
           E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
                E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
           return (course, participant E.^. CourseParticipantRegistration)
@@ -775,7 +790,14 @@ mkEnrolledCoursesTable =
           , sortable (Just "time") (i18nCell MsgProfileRegistered) $ do
               regTime <- view $ _dbrOutput . _2
               return $ dateTimeCell regTime
-            ]
+          , sortable Nothing (i18nCell MsgCourseTutorials) $ \(view $ _dbrOutput . _1 -> Entity{entityKey=cid, entityVal=Course{..}}) ->
+              cell [whamlet|
+                <ul .list--iconless>
+                  $forall tutName <- maybeMonoid (Map.lookup cid usrTutMap)
+                    <li>
+                      ^{simpleLink (citext2widget tutName) (CTutorialR courseTerm courseSchool courseShorthand tutName TUsersR)}
+              |]
+          ]
       , dbtSorting   = Map.fromList
           [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName  )
           , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm  )
@@ -808,9 +830,9 @@ mkSubmissionTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
-        E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
+        EL.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
-        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+        EL.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
-        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+        EL.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
         E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
         let crse = ( course E.^. CourseTerm
                    , course E.^. CourseSchool
@@ -821,7 +843,7 @@ mkSubmissionTable =
       dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
 
       lastSubEdit uid submission = -- latest Edit-Time of this user for submission
-        E.subSelectMaybe . E.from $ \subEdit -> do
+        E.subSelectMaybe . EL.from $ \subEdit -> do
           E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
               E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
           return . E.max_ $ subEdit E.^. SubmissionEditTime
@@ -888,8 +910,8 @@ mkSubmissionGroupTable =
       withType = id
 
       dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
-        E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
+        EL.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
-        E.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
+        EL.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
         E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
         let crse =  ( course E.^. CourseTerm
                     , course E.^. CourseSchool
@@ -942,18 +964,18 @@ mkCorrectionsTable =
               ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
       withType = id
 
-      corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
+      corrsAssigned uid sheet = E.subSelectCount . EL.from $ \submission ->
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
               E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
 
-      corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
+      corrsCorrected uid sheet = E.subSelectCount . EL.from $ \submission ->
           E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
                E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
                E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
 
       dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
-        E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
+        EL.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-        E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
+        EL.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
         E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
         let crse =  ( course E.^. CourseTerm
                     , course E.^. CourseSchool
@@ -1018,9 +1040,9 @@ mkQualificationsTable =
     DBTable
       { dbtIdent     = "userQualifications" :: Text
       , dbtSQLQuery  = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do
-          E.on $ quser E.^. QualificationUserId             E.=?. qblock E.?. QualificationUserBlockQualificationUser
+          EL.on $ quser E.^. QualificationUserId             E.=?. qblock E.?. QualificationUserBlockQualificationUser
             E.&&.  qblock `isLatestBlockBefore` E.val now
-          E.on $ quser E.^. QualificationUserQualification  E.==. quali  E.^. QualificationId
+          EL.on $ quser E.^. QualificationUserQualification  E.==. quali  E.^. QualificationId
           E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
           return (quali, quser, qblock)
       , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
@@ -1078,7 +1100,7 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
-        E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+        EL.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
         E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
         return (usr, spr)
     dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
@@ -1131,7 +1153,7 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
     dbtStyle = def
 
     dbtSQLQuery (usr `E.InnerJoin` spr) = do
-        E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
+        EL.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
         E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
         return (usr, spr)
     dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
@@ -1290,7 +1312,7 @@ postCsvOptionsR = do
   Entity uid User{userCsvOptions} <- requireAuth
 
   userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
-  examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
+  examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . EL.from $ \examOfficeLabel -> do
     E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
     E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
     return $ examOfficeLabel E.^. ExamOfficeLabelName

src/Handler/Submission/List.hs

@@ -48,14 +48,14 @@ import Data.List (genericLength)
 
 import qualified Data.Csv as Csv
 
-
+{-# ANN module ("HLint: ignore Functor law" :: String) #-}
 
 data CorrectionTableFilterProj = CorrectionTableFilterProj
   { corrProjFilterSubmission :: Maybe (Set [CI Char])
   , corrProjFilterPseudonym  :: Maybe (Set [CI Char])
   , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
   }
- 
+
 instance Default CorrectionTableFilterProj where
   def = CorrectionTableFilterProj
     { corrProjFilterSubmission = Nothing
@@ -64,7 +64,7 @@ instance Default CorrectionTableFilterProj where
     }
 
 makeLenses_ ''CorrectionTableFilterProj
-  
+
 
 type CorrectionTableExpr  = (               E.SqlExpr (Entity Course)
                               `E.InnerJoin` E.SqlExpr (Entity Sheet)
@@ -135,7 +135,7 @@ resultSubmittors = _dbrOutput . _6 . itraversed
 
 resultUserUser :: Lens' CorrectionTableUserData User
 resultUserUser = _1
-  
+
 resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
 resultUserPseudonym = _2 . _Just
 
@@ -207,7 +207,7 @@ instance Csv.ToNamedRecord CorrectionTableCsv where
       , "rating-points" Csv..= csvCorrectionRatingPoints
       , "rating-comment" Csv..= csvCorrectionRatingComment
       ]
-    where 
+    where
       mkEmpty = \case
         [Nothing] -> []
         x -> x
@@ -269,7 +269,7 @@ data CorrectionTableCsvQualification
   = CorrectionTableCsvNoQualification
   | CorrectionTableCsvQualifySheet
   | CorrectionTableCsvQualifyCourse
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)    
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
 correctionTableCsvHeader :: Bool -- ^ @showCorrector@
@@ -402,7 +402,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $
 colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
 colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return
 
-  
+
 colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
   let tid = x ^. resultCourseTerm
@@ -457,7 +457,7 @@ colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
         ]
 
 colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell 
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
 
 colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
@@ -515,7 +515,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission
       csh = x ^. resultCourseShorthand
       shn = x ^. resultSheet . _entityVal . _sheetName
       cID = x ^. resultCryptoID
-      
+
       asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
    in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
 
@@ -537,7 +537,7 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat
 
 filterUISubmission :: DBFilterUI
 filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
-  
+
 filterUIPseudonym :: DBFilterUI
 filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
 
@@ -809,7 +809,7 @@ correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator acti
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
-  
+
 correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
 correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler

src/Handler/Tutorial/Users.hs

@@ -50,7 +50,7 @@ data TutorialUserActionData
   | TutorialUserGrantQualificationData
     { tuQualification :: QualificationId
     , tuValidUntil    :: Day
-    }    
+    }
   | TutorialUserSendMailData
   | TutorialUserDeregisterData{}
   deriving (Eq, Ord, Read, Show, Generic)
@@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do
   isAdmin <- hasReadAccessTo AdminR
   (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
+    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
     qualifications <- getCourseQualifications cid
     now <- liftIO getCurrentTime
     let nowaday = utctDay now
@@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do
         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
+          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
           , pure   colUserEmail
           , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
@@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do
           & defaultSortingByName
           & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
           & restrictFilter  (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
-        isInTut q = E.exists $ do 
+        isInTut q = E.exists $ do
           tutorialParticipant <- E.from $ E.table @TutorialParticipant
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
         csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
-    
+
-    let      
+        qualOptions = qualificationsOptionList qualifications
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
+    let
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $
         (if null qualifications then mempty else
           [ ( TutorialUserRenewQualification
             , TutorialUserRenewQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
             )
           , ( TutorialUserGrantQualification
             , TutorialUserGrantQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
               <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-            )                     
+            )
-          ] 
+          ]
         ) ++
         [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
         , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
@@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do
         rcvr <- requireAuth
         encRcvr <- encrypt $ entityKey rcvr
         letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
-        let mbAletter = anyone letters 
+        let mbAletter = anyone letters
-        case mbAletter of 
+        case mbAletter of
           Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
-          Just aletter -> do             
+          Just aletter -> do
             now <- liftIO getCurrentTime
-            apcIdent <- letterApcIdent aletter encRcvr now        
+            apcIdent <- letterApcIdent aletter encRcvr now
             let fName = letterFileName aletter
             renderLetters rcvr letters apcIdent >>= \case
-              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err                      
+              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
               Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
                 -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-                -- let typePDF :: ContentType 
+                -- let typePDF :: ContentType
                 --     typePDF = "application/pdf"
-                -- sendResponse (typePDF, toContent pdf)          
+                -- sendResponse (typePDF, toContent pdf)
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
@@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
-        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers      
+        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
         addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do
@@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
-  
+
-  case tcontent of 
+  case tcontent of
     Just act -> act -- abort and return produced content
     Nothing -> do
       tutors <- runDB $ E.select $ do

src/Handler/Utils/Avs.hs

@@ -51,6 +51,7 @@ import Jobs.Queue
 
 import Utils.Avs
 import Utils.Users
+-- import Utils.Mail (validEmail)
 import Handler.Utils.Users
 import Handler.Utils.Company
 import Handler.Utils.Qualification
@@ -365,11 +366,12 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       , CU_API_UserMatrikelnummer
                       -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
                       ]
-            eml_up =  mkUpdate  usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail                            -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
+            eml_up  = mkUpdate  usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail                            -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
+            -- eml_up2 = mkUpdate  usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserEmail                                -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet
             frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserPostAddress                             -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
             pin_up  = mkUpdate' usr newAvsCardNo     oldAvsCardNo       $                                                                  -- Maybe update PDF pin to latest card
                         CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
-            usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups)))
+            usr_up1 = mconss [eml_up, frm_up, pin_up] $ ldap_ups <> per_ups
             avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
                       [ UserAvsLastSynch      =. now
                       , UserAvsLastSynchError =. Nothing
@@ -443,8 +445,9 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                   -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                   -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                   -- return pst_up
-        update usrId $ usr_up2 <> usr_up1                                         -- update user eventually
+        update usrId usr_up2                                         -- update user by company switch first (due to possible conflicts with usr_up2)
-        update uaId    avs_ups                                                    -- update stored avsinfo for future updates
+        update usrId usr_up1                                         -- update user eventually
+        update uaId  avs_ups                                         -- update stored avsinfo for future updates
       return (apid, usrId)
 
 
@@ -528,6 +531,7 @@ createAvsUserById muid api = do
           (Nothing, Nothing) -> do                              -- create fresh user
             Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
             let pinPass = avsFullCardNo2pin <$> usrCardNo
+                -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior
                 newUserData = AddUserData
                   { audTitle            = Nothing
                   , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
@@ -703,13 +707,14 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi
               )
               (\_old new ->
                 [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor  -- this is already given in case of conflict
-                  UserSupervisorCompany    E.=. new E.^. UserSupervisorCompany
+                  UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-                , UserSupervisorReason     E.=. new E.^. UserSupervisorReason
+                , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
+                , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
                 ]
               )
             reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
           return (cid,supid)
-    | Just oldSupeEmail <- mbOldAfi ^? _Just . _avsFirmEMailSuperior . _Just -- no more superior, delete old one
+    | Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one
       = do
           void $ runMaybeT $ do
             oldAfi <- MaybeT $ pure mbOldAfi
@@ -923,7 +928,7 @@ retrieveDifferingLicences' getStatus = do
         -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
         ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
 #else
-  allLicences  <- avsQuery AvsQueryGetAllLicences
+  allLicences  <- avsQueryNoCache AvsQueryGetAllLicences
 #endif
   lDiff <- getDifferingLicences allLicences
 #ifdef DEVELOPMENT
@@ -955,7 +960,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
   --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
   --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
   -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
-  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
+  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences        -- antitone is ok, see test/Utils/TypesSpec -> "Ord AvsPersonLicence"
       rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
       vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
       rollfeld       = Set.map avsLicencePersonID rollfeld'
@@ -990,7 +995,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
     <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
     <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
   let setTo0      = vorfRevoke                    -- revoke driving licences
-      setTo1up    = vorfGrant Set.\\ rollGrant    -- grant apron driving licence
+      setTo1up    = vorfGrant  Set.\\ rollGrant   -- grant apron driving licence
       setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence
       setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
   return AvsLicenceDifferences

src/Handler/Utils/AvsUpdate.hs

@@ -67,11 +67,11 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where
   mkCheckUpdate CU_API_UserFirstName             = CheckUpdate     UserFirstName               _avsInfoFirstName
   mkCheckUpdate CU_API_UserSurname               = CheckUpdate     UserSurname                 _avsInfoLastName
   mkCheckUpdate CU_API_UserDisplayName           = CheckUpdate     UserDisplayName             _avsInfoDisplayName
-  mkCheckUpdate CU_API_UserBirthday              = CheckUpdate     UserBirthday                _avsInfoDateOfBirth
+  mkCheckUpdate CU_API_UserBirthday              = CheckUpdateMay  UserBirthday                _avsInfoDateOfBirth
-  mkCheckUpdate CU_API_UserMobile                = CheckUpdate     UserMobile                  _avsInfoPersonMobilePhoneNo
+  mkCheckUpdate CU_API_UserMobile                = CheckUpdateMay  UserMobile                  _avsInfoPersonMobilePhoneNo
-  mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdate     UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
+  mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdateMay  UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
-  mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate     UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
+  mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay  UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
-  mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdate     UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
+  mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdateMay  UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
   -- mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
 data CU_AvsDataContcat_User
@@ -82,19 +82,21 @@ data CU_AvsDataContcat_User
 instance MkCheckUpdate CU_AvsDataContcat_User where
   type MCU_Rec CU_AvsDataContcat_User = User
   type MCU_Raw CU_AvsDataContcat_User = AvsDataContact
-  mkCheckUpdate CU_ADC_UserPostAddress  = CheckUpdate    UserPostAddress    _avsContactPrimaryPostAddress
+  mkCheckUpdate CU_ADC_UserPostAddress  = CheckUpdateMay UserPostAddress    _avsContactPrimaryPostAddress
   mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
 
 data CU_AvsFirmInfo_User
   = CU_AFI_UserPostAddress
+  -- CU_AFI_UserEmail               -- PROBLEM: UserEmail must be unique!
   -- CU_AFI_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_AvsFirmInfo_User where
   type MCU_Rec CU_AvsFirmInfo_User = User
   type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
-  mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdate     UserPostAddress             _avsFirmPostAddress
+  mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdateMay  UserPostAddress             _avsFirmPostAddress
-  -- mkCheckUpdate CU_AFI_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
+  -- mkCheckUpdate CU_AFI_UserEmail              = CheckUpdateOpt  UserEmail                 $ _avsFirmEMailSuperior . _Just . from _CI   -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
+  -- mkCheckUpdate CU_AFI_UserDisplayEmail       = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail  . _Just . from _CI   -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
 
 -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!

src/Handler/Utils/Company.hs

@@ -163,10 +163,11 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         usrPrefPost = userPrefersPostal usrRec
         usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
                       (UserPrefersPostal  =. companyPrefersPostal newCompany)
-        usrEmail :: UserEmail       = userDisplayEmail usrRec
+        -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
+        usrDisplayEmail :: UserEmail       = userDisplayEmail usrRec
         avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
-        usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "")
+        usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
-        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp]
+        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
                 --  [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
     -- update uid usrUpdate
     -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association

src/Handler/Utils/Course.hs

@@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or
   ]
 
 getCourseQualifications :: ( MonadHandler m
-                           , backend ~ SqlBackend                           
+                           , backend ~ SqlBackend
-                           ) 
+                           )
                         => CourseId -> ReaderT backend m [Entity Qualification]
-getCourseQualifications cid = Ex.select $ do 
+getCourseQualifications cid = Ex.select $ do
   (qual :& courseQual) <-
     Ex.from $      Ex.table @Qualification
     `Ex.innerJoin` Ex.table @CourseQualification
-    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) 
+    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
   Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
-  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
+  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName]
   pure qual

src/Handler/Utils/Form.hs

@@ -1489,7 +1489,7 @@ boolField' :: ( MonadHandler m
               , HandlerSite m ~ UniWorX
               )
           => Field m Bool
-boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant)
+boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant) -- MsgBoolIrrelevant is shown if the field is optional
 
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX

src/Handler/Utils/Qualification.hs

@@ -289,3 +289,31 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas
         E.&&.  quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
     return $ quser E.^. QualificationUserUser
   qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
+
+
+-----------
+-- Forms --
+-----------
+
+
+qualificationOption :: Entity Qualification -> Option QualificationId
+qualificationOption (Entity qid Qualification{..}) =
+  let qsh = ciOriginal $ unSchoolKey qualificationSchool
+  in  Option{ optionDisplay       = ciOriginal qualificationName      <> " ("  <> qsh <> ")"
+            , optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh  -- both a publicly known already
+            , optionInternalValue = qid
+            }
+
+qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
+qualificationsOptionList = mkOptionList . map qualificationOption
+
+{- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs
+qualOpt :: Entity Qualification -> Handler (Option QualificationId)
+qualOpt (Entity qualId qual) = do
+  cQualId :: CryptoUUIDQualification <- encrypt qualId
+  return $ Option
+    { optionDisplay       = ciOriginal $ qualificationName qual
+    , optionInternalValue = qualId
+    , optionExternalValue = tshow cQualId
+    }
+-}

src/Handler/Utils/Widgets.hs

@@ -94,12 +94,19 @@ nameHtml displayName surname
   | null surname = toHtml displayName
   | otherwise = case reverse $ T.splitOn surname displayName of
       [_notContained]
-        | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName) ->
+        | (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
           let prefix = T.intercalate surname $ reverse prefixes
           in [shamlet|$newline never
-                #{prefix}
+                #{prefix} #
                 <b .surname>#{surname}
-                #{suffix}
+                \ #{suffix}
+              |]
+        | (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
+          let prefix = T.intercalate surname $ reverse prefixes
+          in [shamlet|$newline never
+                #{prefix} #
+                <b .surname>#{surname}
+                \ #{suffix}
               |]
         | otherwise -> [shamlet|$newline never
                             #{displayName} (
@@ -108,11 +115,14 @@ nameHtml displayName surname
       (suffix:prefixes) ->
         let prefix = T.intercalate surname $ reverse prefixes
         in [shamlet|$newline never
-              #{prefix}
+              #{prefix} #
               <b .surname>#{surname}
-              #{suffix}
+              \ #{suffix}
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
+  where
+    fullyNormalize :: Text -> Text
+    fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words
 
 nameHtml' :: HasUser u => u -> Html
 nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)

src/Jobs/Handler/Print.hs

@@ -18,34 +18,52 @@ import qualified Data.Text as Text
 
 -- import           Database.Persist.Sql (deleteWhereCount)
 -- import           Database.Esqueleto.Experimental ((:&)(..))
--- import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.Experimental as E
--- import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
--- import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Legacy as E
 
-
+jobPrintAckChunkSize :: Int
-jobPrintAckChunkSize :: Int 
 jobPrintAckChunkSize = 64
 
+-- | Maximum length difference between received and stored apcIdent
+--   APC sometimes sends ids back that are shorter than expected
+apcIdentMaxDiff :: Int
+apcIdentMaxDiff = 3
+
 -- needed, since JobPrintAck cannot requeue itself due to JobNoQueueSame (and having no parameters)
 dispatchJobPrintAckAgain :: JobHandler UniWorX
 dispatchJobPrintAckAgain = JobHandlerException act
-  where 
+  where
     act = void $ queueJob JobPrintAck
       -- liftIO $ threadDelay 3e6 -- wait 3s before continuing UPDATE: no wait needed
-      
+
 
 dispatchJobPrintAck :: JobHandler UniWorX
 dispatchJobPrintAck = JobHandlerException act
-  where    
+  where
     act = do
-      moretodo <- runDB $ do 
+      moretodo <- runDB $ do
         aliases <- selectList [] [Desc PrintAckIdAliasPriority]
         let ftransAliases = id : fmap (\Entity{entityVal=PrintAckIdAlias{printAckIdAliasNeedle=n, printAckIdAliasReplacement=r}} -> Text.replace n r) aliases
-            ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case
+            ackOneId ackt apci = selectKeysList [PrintJobApcIdent ==. apci, PrintJobAcknowledged ==. Nothing] [Asc PrintJobCreated, LimitTo 1] >>= \case -- mark oldest as done, if there are multiple with the same identifier
-                [pjid]  ->  update pjid [PrintJobAcknowledged =. Just ackt] >>
+                [pjid]  ->  update pjid [PrintJobAcknowledged =. Just ackt] $> True
-                            return True
+                _       ->  do
-                _       ->  return False
+                  pjcs <- E.select $ do
+                    let len_apci   = Text.length apci
+                        ifx_bounds = (E.val $  len_apci - apcIdentMaxDiff, E.val $ len_apci + apcIdentMaxDiff)
+                    pj <- E.from $ E.table @PrintJob
+                    E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
+                        E.&&. (E.length_ (pj E.^. PrintJobApcIdent) `E.between` ifx_bounds)
+                        E.&&. (E.isInfixOf (E.val apci) (pj E.^. PrintJobApcIdent)
+                         E.||. E.isInfixOf (pj E.^. PrintJobApcIdent) (E.val apci)
+                              )
+                    E.orderBy [E.asc $ pj E.^. PrintJobCreated] -- mark oldest printjob as done, if there are multiple matching jobs
+                    E.limit 1
+                    return $ pj E.^. PrintJobId
+                  case pjcs of
+                    [E.Value pjid] -> update pjid [PrintJobAcknowledged =. Just ackt] $> True
+                    _              -> return False
             procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
                 orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
                   True  -> delete paid                                      >> return (succ oks)

src/Mail.hs

@@ -38,7 +38,7 @@ module Mail
   , setDate, setDateCurrent
   , getMailSmtpData
   , _addressName, _addressEmail
-  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
   ) where
 
@@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader))
 
 newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
   deriving (Show, Generic)
-instance Eq AddressEqIgnoreName where 
+instance Eq AddressEqIgnoreName where
   (==)    = (==)    `on` (addressEmail . getAddress)
-instance Ord AddressEqIgnoreName where 
+instance Ord AddressEqIgnoreName where
   compare = compare `on` (addressEmail . getAddress)
 
 
@@ -159,16 +159,19 @@ _partFilename = _partDisposition . dispositionFilename
     dispositionFilename _  DefaultDisposition       = pure DefaultDisposition
 
 _mailHeader :: CI ByteString -> Traversal' Mail Text
-_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+_mailHeader = (_mailHeaders .) . _mailHeader'
 
-_mailReplyTo' :: Lens' Mail Text 
+_mailHeader' :: CI ByteString -> Traversal' Headers Text
+_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+
+_mailReplyTo' :: Lens' Mail Text
 _mailReplyTo' = _mailHeaders . _headerReplyTo'
 
-_headerReplyTo' :: Lens' Headers Text 
+_headerReplyTo' :: Lens' Headers Text
 --  Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
-  where 
+  where
-    replyto = "Reply-To"        
+    replyto = "Reply-To"
 
 _mailReplyTo :: Lens' Mail Address
 _mailReplyTo = _mailHeaders . _headerReplyTo
@@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
 _headerReplyTo :: Lens' Headers Address
 --  Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
-  where 
+  where
-    replyto = "Reply-To"        
+    replyto = "Reply-To"
     -- _addressEmail :: Lens' Address Text might help to simplify this code?
 
 newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
@@ -270,7 +273,7 @@ instance Exception MailException
 class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
   defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
-  
+
   envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
   envelopeFromAddress = addressEmail <$> defaultFromAddress
 
@@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m
               -> MailT m a
               -> m a
 defMailT ls (MailT mailC) = do
-  fromAddress <- defaultFromAddress  
+  fromAddress <- defaultFromAddress
-  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)  
+  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
   mail1 <- maybeT (return mail0) $ do
     guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
     domain <- mailObjectIdDomain
-    let sender = mail0 ^. _mailFrom 
+    let sender = mail0 ^. _mailFrom
         isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
     $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
     guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
@@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where
   (<>) = mappenddefault
 
 instance Monoid (PrioritisedAlternatives m) where
-  mempty = memptydefault  
+  mempty = memptydefault
 
 class YesodMail site => ToMailPart site a where
   type MailPartReturn site a :: Type
@@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where
     _partContent .= PartContent (fromStrict $ Yaml.encode val)
 
 
-data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } 
+data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
 
 instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
   type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
-  toMailPart nmp = do 
+  toMailPart nmp = do
-    r <- toMailPart $ namedPart nmp 
+    r <- toMailPart $ namedPart nmp
     _partDisposition .= disposition nmp
-    return r    
+    return r
 
 
 addAlternatives :: (MonadMail m)
@@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
 lookupMailHeader = fmap listToMaybe . getMailHeaders
 
 mapMailHeader ::  MonadHeader m => MailHeader -> (Text -> Text) -> m ()
-mapMailHeader header f = modifyHeaders $ adjustAssoc f header 
+mapMailHeader header f = modifyHeaders $ adjustAssoc f header
 
 replaceMailHeaderI :: ( RenderMessage site msg
                       , MonadMail m
@@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do
 
   tell $ mempty
     { smtpRecipients = recps
-    , smtpEnvelopeFrom = Last $ Just from 
+    , smtpEnvelopeFrom = Last $ Just from
     }

src/Model/Types/Avs.hs

@@ -216,7 +216,7 @@ instance PersistFieldSql AvsFullCardNo where
 parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo)
 parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo)
 
-discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) 
+discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo)
 discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo)
 
 -- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot
@@ -227,7 +227,7 @@ splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv))
     = Just $ Left $ fl c
   | Just ('.', v) <- Text.uncons pv
   , Just (Char.isDigit -> True, "") <- Text.uncons v
-    = Just $ Right $ fr c v 
+    = Just $ Right $ fr c v
 splitDigitsByDot _ _ _ = Nothing
 
 -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId`
@@ -453,7 +453,7 @@ deriveJSON defaultOptions
   } ''AvsStatusPerson
 
 makeLenses_ ''AvsStatusPerson
-  
+
 
 data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
@@ -551,7 +551,7 @@ _avsInfoDisplayName :: Lens' AvsPersonInfo Text
 _avsInfoDisplayName = lens g s
   where
     g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName
-    s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn 
+    s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn
                in api{avsInfoFirstName = fn, avsInfoLastName = ln}
 
 
@@ -603,7 +603,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where
 makeLenses_ ''AvsFirmCommunication
 _avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text)
 _avsCommunicationAddress = to mkAddr
-  where 
+  where
     mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry
 
 instance FromJSON AvsFirmCommunication where
@@ -645,7 +645,7 @@ _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo
 _avsFirmPostAddress = to mkPost
   where
     mkPost afi@AvsFirmInfo{avsFirmFirm} =
-        let someAddr = afi ^. _avsFirmPostAddressSimple 
+        let someAddr = afi ^. _avsFirmPostAddressSimple
             prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
         in prefAddr <$> someAddr
 
@@ -657,27 +657,27 @@ _avsFirmPostAddressSimple = to mkPost
     mkPost AvsFirmInfo{..} =
         let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
             commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
-        in  asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] 
+        in  asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
 
 _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
 _avsFirmPrimaryEmail = to mkEmail
   where
     mkEmail afi =
-      let candidates =  catMaybes 
+      let candidates =  catMaybes
               [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
               , afi ^. _avsFirmEMail
-              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email              
+              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
               ]
       in pickValidEmail candidates -- should we return an invalid email rather than none?
 
 -- | Not sure this is useful, since postal is ignored if there is no post address anyway
 _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
 _avsFirmPrefersPostal = to mkPostPref
-  where 
+  where
     mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
 
 -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead
--- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text 
+-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
 -- _avsFirmAddress = to mkAddr
 --   where
 --     mkAddr AvsFirmInfo{..} =
@@ -726,12 +726,12 @@ makeLenses_ ''AvsDataContact
 _avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text)
 _avsContactPrimaryEmail = to mkEmail
   where
-    mkEmail adc = 
+    mkEmail adc =
       let candidates = catMaybes
             [ adc ^. _avsContactFirmInfo   . _avsFirmCommunication . _Just . _avsCommunicationEMail
             , adc ^. _avsContactFirmInfo   . _avsFirmEMail
             , adc ^. _avsContactPersonInfo . _avsInfoPersonEMail
-            , adc ^. _avsContactFirmInfo   . _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email      
+            -- , adc ^. _avsContactFirmInfo   . _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email. Superior email is used as systemEmail only.
             ]
       in pickValidEmail candidates -- should we return an invalid email rather than none?
 
@@ -848,15 +848,15 @@ fixAvsQueryPerson AvsQueryPerson{avsPersonQueryVersionNo=Nothing, avsPersonQuery
     = AvsQueryPerson
         { avsPersonQueryCardNo             = Just acn1
         , avsPersonQueryVersionNo          = Just avc1
-        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName         
+        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName
-        , avsPersonQueryLastName           = canonical avsPersonQueryLastName          
+        , avsPersonQueryLastName           = canonical avsPersonQueryLastName
         , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
         }
 fixAvsQueryPerson AvsQueryPerson{..} = AvsQueryPerson
-        { avsPersonQueryCardNo             = canonical avsPersonQueryCardNo            
+        { avsPersonQueryCardNo             = canonical avsPersonQueryCardNo
-        , avsPersonQueryVersionNo          = canonical avsPersonQueryVersionNo         
+        , avsPersonQueryVersionNo          = canonical avsPersonQueryVersionNo
-        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName         
+        , avsPersonQueryFirstName          = canonical avsPersonQueryFirstName
-        , avsPersonQueryLastName           = canonical avsPersonQueryLastName          
+        , avsPersonQueryLastName           = canonical avsPersonQueryLastName
         , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo
         }
 
@@ -878,7 +878,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
 
 data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero)
   deriving (Eq, Ord, Show, Generic)
-  
+
 newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQuerySetLicences

src/Model/Types/Mail.hs

@@ -34,6 +34,7 @@ import Data.ByteString.Base32
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Database.Esqueleto.Experimental as E
 
 -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
 --
@@ -121,7 +122,7 @@ instance PathPiece BounceSecret where
   toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
   fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
 
-newtype MailContent = MailContent [Alternatives]
+newtype MailContent = MailContent {getMailContent :: [Alternatives]}
   deriving (Eq, Show, Generic)
   deriving newtype (ToJSON, FromJSON)
   deriving anyclass (Binary, NFData)
@@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where
   sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
 
 derivePersistFieldJSON ''MailHeaders
+
+instance E.SqlString MailHeaders

src/Network/Mail/Mime/Instances.hs

@@ -56,8 +56,7 @@ instance Csv.ToNamedRecord Address where
 instance Csv.DefaultOrdered Address where
   headerOrder _ = Csv.header [ "name", "email" ]
 
-  
+newtype MailHeaders = MailHeaders {toHeaders:: Headers}
-newtype MailHeaders = MailHeaders Headers
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (NFData)
 
@@ -79,7 +78,7 @@ deriving anyclass instance NFData PartContent
 deriving anyclass instance NFData Part
 deriving anyclass instance NFData Address
 deriving anyclass instance NFData Mail
-  
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
   } ''Encoding

src/Utils.hs

@@ -714,9 +714,9 @@ bcons :: Bool -> a -> [a] -> [a]
 bcons False _ = id
 bcons True  x = (x:)
 
-bsnoc :: Bool -> a -> [a] -> [a]
+bsnoc :: Bool -> [a] -> a -> [a]
-bsnoc False _ xs = xs
+bsnoc False xs _ = xs
-bsnoc True  x xs = xs ++ [x]
+bsnoc True  xs x = xs ++ [x]
 
 -- | Merge/Add any attribute-value pair to an existing list of such pairs.
 --   If the attribute exists, the new valu will be prepended, separated by a single empty space
@@ -879,6 +879,12 @@ mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT .
 _MapUnit :: Iso' (Map k ()) (Set k)
 _MapUnit = iso Map.keysSet $ Map.fromSet (const ())
 
+foldMapWithKeyM :: (Monad m, Monoid o) => (k -> a -> m o) -> Map k a -> m o
+foldMapWithKeyM act = foldMapM (uncurry act) . Map.toAscList
+
+foldWithKeyMapM :: (Monad m, Monoid o) => Map k a -> (k -> a -> m o) -> m o
+foldWithKeyMapM = flip foldMapWithKeyM
+
 ---------------
 -- Functions --
 ---------------
@@ -991,6 +997,7 @@ catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e ->
 catchIfMPlus p act = catchIf p act (const mzero)
 
 -- | Monadic version of 'fromMaybe'
+--   Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4], use `mconss` instead
 fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
 fromMaybeM act = maybeM act pure
 
@@ -1001,6 +1008,13 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs
 
+mconss :: [Maybe a] -> [a] -> [a]
+mconss    []  tl = tl
+mconss (m:xs) tl
+  | Just x <- m = x : mconss xs tl
+  | otherwise   =     mconss xs tl
+
+
 -- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
 ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
 ignoreNothing _ Nothing y = y
@@ -1297,7 +1311,7 @@ ofoldl1M _ _ = error "otoList of NonNull is empty"
 foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
 foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty
 
-{- left as a remineder: if you need these, use MaybeT instead!
+{- left as a reminder: if you need these below, rather use MaybeT instead!
 -- convenient synonym for `flip foldMapM`
 continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b
 continueJust (Just x) f = f x
@@ -1433,6 +1447,26 @@ anyone :: (Foldable t, Alternative f) => t a -> f a
 anyone = Fold.foldr ((<|>).pure) empty
 
 
+
+-- returns true, if the foldable contains an element twice
+hasDuplicates :: (Foldable t, Ord a) => t a -> Bool
+hasDuplicates = fst . Fold.foldl' aux (False, mempty)
+  where
+    aux r@(True ,  _) _   = r
+    aux   (False, xs) x
+      | x `Set.member` xs = (True , xs)
+      | otherwise         = (False, Set.insert x xs)
+
+{-
+-- | like `hasDuplicates` but terminates on infinte lists that contain duplicates
+hasDuplicates' :: Ord a => [a] -> Bool
+hasDuplicates' = aux mempty
+  where
+    aux _       []  = False
+    aux seen (x:xs) = Set.member x seen || aux (Set.insert x seen) xs
+-}
+
+
 ------------
 -- Writer --
 ------------

src/Utils/DB.hs

@@ -43,14 +43,14 @@ getField = view . fieldLensVal
 -- | Obtain a lens from an EntityField
 fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ
 fieldLensVal f = entityLens . fieldLens f
-  where 
+  where
     entityLens :: Lens' record (Entity record)
     entityLens = lens getVal setVal
     getVal :: record -> Entity record
     getVal   = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
     setVal :: record -> Entity record -> record
     setVal _ = entityVal
-    
+
 
 emptyOrIn :: PersistField typ
           => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
@@ -115,16 +115,16 @@ existsKey404 = bool notFound (return ()) <=< existsKey
 
 -- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
 --   getByPeseudoUnique
-getByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) 
+getByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
             =>  [Filter record] -> ReaderT backend m (Maybe (Entity record))
-getByFilter crit = 
+getByFilter crit =
-  selectList crit [LimitTo 2] <&> \case  
+  selectList crit [LimitTo 2] <&> \case
     [singleEntity] -> Just singleEntity
     _              -> Nothing -- not existing or not unique
 
-getKeyByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) 
+getKeyByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
             =>  [Filter record] -> ReaderT backend m (Maybe (Key record))
-getKeyByFilter crit = 
+getKeyByFilter crit =
   selectKeysList crit [LimitTo 2] <&> \case
     [singleKey] -> Just singleKey
     _           -> Nothing -- not existing or not unique
@@ -142,9 +142,9 @@ updateGetEntity k = fmap (Entity k) . updateGet k
 
 -- | insert or replace a record based on a single uniqueness constraint
 --   this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record
-replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) 
+replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend)
               => record -> ReaderT backend m ()
-replaceBy r = do 
+replaceBy r = do
   u <- onlyUnique r
   deleteBy u
   insert_ r
@@ -189,15 +189,15 @@ replaceEntity Entity{..} = replace entityKey entityVal
 --  * Unique denotes old record
 --  * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists
 
--- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint  
+-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint
 upsertBySafe :: ( MonadIO m
                 , PersistEntity record
                 , PersistUniqueWrite backend
                 , PersistEntityBackend record ~ BaseBackend backend
-                ) 
+                )
              => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record))
 upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq)
-  where 
+  where
     do_upd Entity{entityKey = oid, entityVal = oldr} = do
       delete oid
       insertUnique $ upd oldr
@@ -263,13 +263,13 @@ instance WithRunDB backend m (ReaderT backend m) where
   useRunDB = id
 
 -- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special:
--- updateWithMessage 
+-- updateWithMessage
 --   :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend
 --       , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)]))
 --   => url                 -- where to redirect, if changes were mage
 --   -> [Filter val]        -- update filter
 --   -> [Update val]        -- actual update
---   -> a                   -- expected updates 
+--   -> a                   -- expected updates
 --   -> (a -> msg)          -- message to add with number of actual changes
 --   -> HandlerFor site ()
 -- updateWithMessage route flt upd no_req msg = do
@@ -290,7 +290,7 @@ instance WithRunDB backend m (ReaderT backend m) where
 --                      DBRunner site
 --                   -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
 --     fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
-    
+
 --     toDBRunner :: forall site.
 --                   DBRunner' (YesodPersistBackend site) (HandlerFor site)
 --                -> DBRunner site
@@ -332,27 +332,34 @@ instance WithRunDB backend m (ReaderT backend m) where
 --             void . atomically $ tryPutTMVar runnerTMVar runner
 --             return runner
 --       getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
-  
+
 --   runCachedDBRunnerUsing act getRunnerNoLock
 
 
 
 -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
-data CheckUpdate record iraw = 
+data CheckUpdate record iraw =
-    forall typ. (Eq typ, PersistField typ) => 
+    forall typ. (Eq typ, PersistField typ) =>
     CheckUpdate     (EntityField record typ) (Getting               typ  iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ')
-  | forall typ. (Eq typ, PersistField typ) => 
+  | forall typ. (Eq typ, PersistField typ) =>
+    CheckUpdateMay  (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values
+  | forall typ. (Eq typ, PersistField typ) =>
     CheckUpdateOpt  (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB.
 
 -- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround
 -- instance Lift (CheckUpdate record iraw) where
 --   lift = $(makeLift ''CheckUpdate)
 
+-- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions
 mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool
 mayUpdate ent (Just old) (CheckUpdate up l)
   | let oldval = old ^. l
   , let entval = ent ^. fieldLensVal up
-    = oldval == entval   
+    = oldval == entval
+mayUpdate ent (Just old) (CheckUpdateMay up l)
+  | let oldval = old ^. l
+  , let entval = ent ^. fieldLensVal up
+    = isNothing entval || oldval == entval
 mayUpdate ent (Just old) (CheckUpdateOpt up l)
   | Just oldval <- old ^? l
   , let entval = ent ^. fieldLensVal up
@@ -369,6 +376,12 @@ mkUpdate ent new (Just old) (CheckUpdate up l)
   , newval /= entval
   , oldval == entval
     = Just (up =. newval)
+mkUpdate ent new (Just old) (CheckUpdateMay up l)
+  | let newval = new ^. l
+  , let oldval = old ^. l
+  , let entval = ent ^. fieldLensVal up
+  , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
+    = Just (up =. newval)
 mkUpdate ent new (Just old) (CheckUpdateOpt up l)
   | Just newval <- new ^? l
   , Just oldval <- old ^? l
@@ -383,12 +396,18 @@ mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate
 mkUpdate' ent new Nothing = mkUpdateDirect ent new
 mkUpdate' ent new just    = mkUpdate       ent new just
 
+-- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different
 mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
 mkUpdateDirect ent new (CheckUpdate up l)
   | let newval = new ^. l
   , let entval = ent ^. fieldLensVal up
   , newval /= entval
     = Just (up =. newval)
+mkUpdateDirect ent new (CheckUpdateMay up l)
+  | let newval = new ^. l
+  , let entval = ent ^. fieldLensVal up
+  , newval /= entval
+    = Just (up =. newval)
 mkUpdateDirect ent new (CheckUpdateOpt up l)
   | Just newval <- new ^? l
   , let entval = ent ^. fieldLensVal up
@@ -398,33 +417,43 @@ mkUpdateDirect _ _ _ = Nothing
 
 -- | Unconditionally update a record through CheckUpdate
 updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
-updateRecord ent new (CheckUpdate up l) = 
+updateRecord ent new (CheckUpdate up l) =
+  let newval  = new ^. l
+      lensRec = fieldLensVal up
+  in  ent & lensRec .~ newval
+updateRecord ent new (CheckUpdateMay up l) =
   let newval  = new ^. l
       lensRec = fieldLensVal up
   in  ent & lensRec .~ newval
 updateRecord ent new (CheckUpdateOpt up l)
-  | Just newval <- new ^? l  
+  | Just newval <- new ^? l
     = ent & fieldLensVal up .~ newval
   | otherwise
-    = ent  
+    = ent
 
 -- | like mkUpdate' but only returns the update if the new value would be unique
 -- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
-mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) 
+mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
                     => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))
-
 mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l)
   | let newval = new ^. l
   , let entval = ent ^. fieldLensVal up
   , newval /= entval
-    = do 
+    = do
+        newval_exists <- exists [up ==. newval]
+        return $ toMaybe (not newval_exists) (up =. newval)
+mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l)
+  | let newval = new ^. l
+  , let entval = ent ^. fieldLensVal up
+  , newval /= entval
+    = do
         newval_exists <- exists [up ==. newval]
         return $ toMaybe (not newval_exists) (up =. newval)
 mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l)
   | Just newval <- new ^? l
   , let entval = ent ^. fieldLensVal up
   , newval /= entval
-    = do 
+    = do
         newval_exists <- exists [up ==. newval]
         return $ toMaybe (not newval_exists) (up =. newval)
 mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
@@ -433,7 +462,15 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
   , let entval = ent ^. fieldLensVal up
   , newval /= entval
   , oldval == entval
-    = do 
+    = do
+        newval_exists <- exists [up ==. newval]
+        return $ toMaybe (not newval_exists) (up =. newval)
+mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l)
+  | let newval = new ^. l
+  , let oldval = old ^. l
+  , let entval = ent ^. fieldLensVal up
+  , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
+    = do
         newval_exists <- exists [up ==. newval]
         return $ toMaybe (not newval_exists) (up =. newval)
 mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
@@ -442,7 +479,7 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
   , let entval = ent ^. fieldLensVal up
   , newval /= entval
   , oldval == entval
-    = do 
+    = do
         newval_exists <- exists [up ==. newval]
         return $ toMaybe (not newval_exists) (up =. newval)
 mkUpdateCheckUnique' _ _ _ _ = return Nothing

src/Utils/Lens.hs

@@ -186,8 +186,8 @@ class HasEntity c record where
   hasEntity :: Lens' c (Entity record)
 
 --Trivial instance, usefull for lifting to maybes
-instance HasEntity (Entity r) r where 
+instance HasEntity (Entity r) r where
-  hasEntity = id 
+  hasEntity = id
 
 -- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want.
 hasEntityUser :: (HasEntity a User) => Lens' a (Entity User)
@@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
 makeWrapped ''Textarea
 makeLenses_ ''SentMail
 
+_mailHeaders' :: Iso' MailHeaders Headers
+_mailHeaders' = coerced
+
 makePrisms ''RoomReference
 makeLenses_ ''RoomReference
 

templates/adminUser.hamlet

@@ -8,8 +8,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   ^{thisUserActWgt}
 <section>
   ^{userDataWidget}
-<section>
+
-  <h3>
+  <p>
+  #{iconNotificationSent} 
+  <a href=@{CommCenterR}?comms-sorting=date-desc&comms-recipient=#{toPathPiece userDisplayName}>
+    _{MsgAdminUserAllNotifications}
+
+
+<h3>
     _{MsgAdminUserRightsHeading}
   ^{systemFunctionsForm}
   ^{rightsForm}

templates/comm-center.hamlet

@@ -0,0 +1,9 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <p> 
+    ^{ccTable}

templates/i18n/lms-all/de-de-formal.hamlet

@@ -7,6 +7,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 <section>
   ^{lmsTable}
 
+  <p>
+    <em>Hinweis: #
+    Es muss anderweitig sichergestellt werden, dass die hier lediglich angezeigte maximale Anzahl #
+    an E‑Learning Prüfungsversuchen mit der im externen LMS eingestellten Zahl übereinstimmt! #
+    Die Begrenzung der Prüfungsversuche wird ausschließlich durch das externe LMS kontrolliert, #
+    an FRADrive wird weder die Anzahl der möglichen noch der erfolgten Versuche übermittelt. #
+    Die hier eingestellte Zahl dient ausschließlich zur Information der Lizenzinhaber per Brief oder E‑Mail.
+    
+
 $maybe btnForm <- mbBtnForm
   <section>
     <h3>

templates/i18n/lms-all/en-eu.hamlet

@@ -7,6 +7,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 <section>
   ^{lmsTable}
 
+  <p>
+      <em>Note: #
+      It must be ensured that the maximum number of e‑learning exam attempts #
+      configured in the external LMS agrees with the number displayed here for the corresponding qualification. #
+      The maximum number of attempts is a setting of the external LMS only, which is never transmitted to FRADrive. #
+      The number shown is only used in the communication to licences holders via letter or Email.
+      
+
 $maybe btnForm <- mbBtnForm
   <section>
     <h3>

templates/i18n/profile-remarks/de-de-formal.hamlet

@@ -9,6 +9,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <ul>
     <li>
       Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Kursleiterschaft, Raumbuchungen, etc.
+    <li>
+      Nicht aufgeführt sind die an diesen Benutzer versendeten Benachrichtigungen per E-Mail oder Briefpost.
     <li>
       <p>
         Sie können die

templates/i18n/profile-remarks/en-eu.hamlet

@@ -9,6 +9,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <ul>
     <li>
       Timestamps with user information (e.g. editing of corrections, submission groups, rooms, ...) are not shown here.
+    <li>
+      Sent notifications by email or letter are not shown here.
     <li>
       <p>
         You can request your data be deleted by opening

templates/mail-center.hamlet

@@ -0,0 +1,9 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <p> 
+    ^{mcTable}

templates/profileData.hamlet

@@ -209,7 +209,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <div .container>
     <h2>_{MsgProfileQualifications}
     <div .container>
-      ^{qualificationsTable}
+      ^{qualificationsTable}  
 
   ^{maybeTable MsgProfileCourses ownedCoursesTable}
   
@@ -221,5 +221,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   
   ^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
   
-
 ^{profileRemarks}

templates/widgets/massinput/courseQualifications/add.hamlet

@@ -0,0 +1,9 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+^{formView}
+<td .table__td>
+  ^{fvWidget submitView}

templates/widgets/massinput/courseQualifications/form.hamlet

@@ -0,0 +1,11 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<td .table__td>
+  #{csrf}
+  ^{fvWidget cquView}
+<td .table__td>
+  ^{fvWidget ordView}

templates/widgets/massinput/courseQualifications/layout.hamlet

@@ -0,0 +1,21 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<table .table .table--striped .table--hover>
+  <thead>
+    <tr .table__row .table__row--head>
+      <th .table__th>_{MsgTableQualification}
+      <th .table__th>_{MsgSortPriority}
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell .table__row>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvWidget (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

test/Database/Fill.hs

@@ -1098,7 +1098,7 @@ fillDb = do
           , tutorialFirstDay        = Just firstDay
           }
         insert_ $ Tutor tut1 jost
-        insert_ Tutorial
+        tut2 <- insert Tutorial
           { tutorialName = mkName "Vorlage"
           , tutorialCourse = c
           , tutorialType = "Vorlage"
@@ -1138,7 +1138,7 @@ fillDb = do
           , tutorialTutorControlled = True
           , tutorialFirstDay        = Just firstDay
           }
-        insert_ Tutorial
+        tut3 <- insert Tutorial
           { tutorialName = mkName "Sondertutoriumsvorlage"
           , tutorialCourse = c
           , tutorialType = "Vorlage_Sondertutorium"
@@ -1178,6 +1178,16 @@ fillDb = do
           , tutorialTutorControlled = True
           , tutorialFirstDay        = Just $ succ $ succ firstDay
           }
+        insert_ $ CourseParticipant c jost    now   CourseParticipantActive
+        insert_ $ CourseParticipant c gkleen  now $ CourseParticipantInactive True
+        insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False
+        insert_ $ CourseParticipant c svaupel now   CourseParticipantActive
+        insert_ $ TutorialParticipant tut1 svaupel
+        insert_ $ TutorialParticipant tut2 svaupel
+        when (odd  tyear) $ insert_ $ TutorialParticipant tut3 svaupel
+        insert_ $ TutorialParticipant tut1 gkleen
+        insert_ $ TutorialParticipant tut2 fhamann
+        when (even tyear) $ insert_ $ TutorialParticipant tut3 jost
         when (odd tyear) $
           void . insert' $ Exam
             { examCourse = c