chore(tutorial): (WIP) towards #90 write form columns

columns are distinguished by user and the entities given in parenthesis:
- driving permit (tutorial)
- eye exam (tutrial)
- tutorial note (tutorial)
- attendance (tutorial & day)
- attendance-note (tutorial & day)
- parking permit (day)

CHANGELOG.md

@@ -2,43 +2,6 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
-## [27.4.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
-
-
-### Bug Fixes
-
-* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
-* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
-
-## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
-
-
-### Bug Fixes
-
-* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
-* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
-* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
-* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
-* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
-
-## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
-
-
-### Bug Fixes
-
-* **avs:** attempt LDAP upsert before creating avs users ([cfe2318](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cfe2318f81c951a7f7310e8bcd9ec25d79417587))
-* **avs:** company superiors are now irregular supervisors and old ones are deleted ([7e5c256](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7e5c256b4c15a15f7218dd7c1490d5e7add4b1c1))
-* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) implement automatic avs driving licence synchronisation ([cc5da9a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1))
-* **avs:** switch company did not always increase priority ([8ec2875](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8ec2875590718f28c3bab8c10141065e11f1405c))
-* **build:** minor linter fix ([be5e609](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be5e609b1fe879428784d78fa62a559d0764a85a))
-* **firm:** fix [#174](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/174) by adding address search filter to all company view ([40dadd5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/40dadd58762156005b5889b93a56ffdc044b4460))
-* **firm:** fix [#175](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/175) by separating superiors in firm tables and selections ([8397c46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8397c468a04af42ba3baee2f84a0051adbc74374))
-* **ldap:** no more timeout for ldap synch all button ([f946e99](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f946e99da3bc37514a4e3621438ac133cdc16732))
-* **linter:** minor bug in exam-correct.hs ([8bc3663](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8bc3663ee2e4ded19091ebe350de82cd693093fc))
-* **mail:** display html emails no longer distorts page ([b0972bb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b0972bb154f453edd545fb4f658d9f5ff79966eb)), closes [#2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/2)
-* **model:** flip erroneous boolean SQL default for CompanyPostalAddress ([b7e5b8f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7e5b8f111b5115d816d984c6ef2f12edfcef5bb))
-* **user:** fix pagination and count for supervision tables ([9c82558](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9c82558d71a032dad27e892c489c7004d091e088))
-
 ## [27.4.76](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.75...v27.4.76) (2024-08-08)
 
 

config/develop-settings.yml

@@ -0,0 +1,21 @@
+# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
+# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
+# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
+# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
+
+
+#DEVELOPMENT ONLY, NOT TO BE USED IN PRODUCTION
+
+avs-licence-synch:
+  times:          [12]
+  level:          4
+  reason-filter:  "(firm|block)"
+  max-changes:    999
+
+# Enqueue at specified hour, a few minutes later
+job-lms-qualifications-enqueue-hour: 16
+job-lms-qualifications-dequeue-hour: 4

config/settings.yml

@@ -91,10 +91,6 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600"   # alle 6
 study-features-recache-relevance-within: 172800
 study-features-recache-relevance-interval: 293
 
-# Enqueue at specified hour, a few minutes later
-job-lms-qualifications-enqueue-hour: 16
-job-lms-qualifications-dequeue-hour: 4
-
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"
   all:           "_env:LOG_ALL:false"
@@ -208,9 +204,6 @@ memcached:
   timeout:    "_env:MEMCACHED_TIMEOUT:20"
   expiration: "_env:MEMCACHED_EXPIRATION:300"
 memcache-auth: true
-memcached-local:
-  maximum-ghost: 512
-  maximum-weight: 104857600 # 100MiB
 
 upload-cache:
   host: "_env:UPLOAD_S3_HOST:" # should be optional, but all file transfers will be empty without an S3 cache
@@ -322,17 +315,6 @@ fallback-personalised-sheet-files-keys-expire: 2419200
 
 download-token-expire: 604801
 
-file-source-arc:
-  maximum-ghost: 512
-  maximum-weight: 1073741824 # 1GiB
-file-source-prewarm:
-  maximum-weight: 1073741824 # 1GiB
-  start: 1800 # 30m
-  end: 600 # 10m
-  inhibit: 3600 # 60m
-  steps: 20
-  max-speedup: 3
-
 bot-mitigations:
   - only-logged-in-table-sorting
   - unauthorized-form-honeypots

load/Load.hs

@@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
 instance PathPiece DiffTime where
   toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
   fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps
-  
+
 
 data LoadSimulation
   = LoadSheetDownload
@@ -214,13 +214,13 @@ runSimulation sim = do
   delays <- replicateM (fromIntegral p) $ do
     d <- view $ _2 . _simDelay
     sampleNDiffTime d
-   
+
   forConcurrently_ ([1..p] `zip` sort delays) $ \(n, d') -> do
     begin <- liftIO getCurrentTime
 
     dur <- view $ _2 . _simDuration
     tDuration <- sampleNDiffTime dur
-    
+
     let MkFixed us = realToFrac d' :: Micro
     threadDelay $ fromInteger us
     start <- liftIO getCurrentTime
@@ -268,7 +268,7 @@ runSimulation' LoadSheetSubmission = do
   -- Just formData <- return . getFormData FIDsubmission $ resp ^. responseBody
   -- Just addButtonData <- return . flip (runFormScraper FIDsubmission) (resp ^. responseBody) $ do
   --   let btnSel = "button" Scalpel.@: [Scalpel.hasClass "btn-mass-input-add"]
-    
+
   --   name <- Scalpel.attr "name" btnSel
   --   value <- Scalpel.attr "value" btnSel
   --   guard $ value == "add__0__0"
@@ -305,7 +305,7 @@ runSimulation' LoadSheetSubmission = do
   procEnd <- join $ asks runtime
 
   print ("proc", procEnd - procStart)
-  
+
   resp3 <- liftIO . httpRetry $ Session.post session (uriToString id formURI mempty) subData
   void . evaluate $! resp3
   where
@@ -328,11 +328,11 @@ runSimulation' LoadSheetSubmission = do
                        -> m ()
             logRetry shouldRetry err status = liftIO . putStrLn . pack $ Retry.defaultLogMsg shouldRetry err status
 
-    
+
 -- runSimulation' other = terror $ "Not implemented: " <> tshow other
 
 runFormScraper :: FormIdentifier -> Scalpel.Scraper Lazy.ByteString a -> Lazy.ByteString -> Maybe a
-runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $ 
+runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $
   fmap listToMaybe . Scalpel.chroots "form" $ do
     fid' <- Scalpel.attr "value" $ "input" Scalpel.@: ["name" Scalpel.@= "form-identifier"]
     guard $ fid' == encodeUtf8 (fromStrict $ toPathPiece fid)
@@ -341,11 +341,11 @@ runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $
 
 getFormData :: FormIdentifier -> Lazy.ByteString -> Maybe [FormParam]
 getFormData = flip runFormScraper $
-  Scalpel.chroots ("input") $ do
+  Scalpel.chroots "input" $ do
     name <- Scalpel.attr "name" Scalpel.anySelector
     value <- Scalpel.attr "value" Scalpel.anySelector <|> pure ""
     return $ toStrict name := value
-      
+
 
 newLoadSession :: ReaderT SimulationContext IO Session
 newLoadSession = do
@@ -354,7 +354,7 @@ newLoadSession = do
   let withToken = case loadToken of
         Nothing -> id
         Just (Jwt bs) -> (:) (hAuthorization, "Bearer " <> bs) . filter ((/= hAuthorization) . fst)
-      
+
 
   liftIO . Session.newSessionControl (Just mempty) $ tlsManagerSettings
     { managerModifyRequest = \req -> return $ req { requestHeaders = withToken $ requestHeaders req }

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -36,6 +36,7 @@ TutorialDelete: Löschen
 TutorialsHeading: Kurse
 TutorialNew: Neuer Kurs
 TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Kurs #{tutn} angemeldet
+TutorialRegisteredFail    tutn@TutorialName: Anmeldung zum Kurs #{tutn} fehlgeschlagen. Existiert bereits eine Anmeldung?
 TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Kurs #{tutn} abgemeldet
 MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{tid}-#{ssh}-#{csh}] Einladung zum Ausbilder für #{tutn}
 TutorInviteHeading tutn@TutorialName: Einladung zum Ausbilder/zur Ausbilderin für #{tutn}
@@ -49,4 +50,9 @@ TutorialUserGrantQualification: Qualifikation vergeben
 TutorialUserRenewQualification: Qualifikation regulär verlängern
 TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
 TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
-CommTutorial: Kursmitteilung
+CommTutorial: Kursmitteilung
+TutorialDrivingPermit: Führerschein
+TutorialEyeExam: Sehtest
+TutorialNote: Kursnotiz
+TutorialDayAttendance day@Text: Anwesenheit am #{day}
+TutorialDayNote day@Text: Anwesenheitsnotiz für #{day}

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -36,6 +36,7 @@ TutorialDelete: Delete
 TutorialsHeading: Courses
 TutorialNew: New course
 TutorialRegisteredSuccess tutn: Successfully registered for the course #{tutn}
+TutorialRegisteredFail    tutn: Registering for the course #{tutn} failed. Probably already registered?
 TutorialDeregisteredSuccess tutn: Successfully de-registered for the course #{tutn}
 MailSubjectTutorInvitation tid ssh csh tutn: [#{tid}-#{ssh}-#{csh}] Invitation to be a instructor for #{tutn}
 TutorInviteHeading tutn: Invitation to be instructor for #{tutn}
@@ -51,3 +52,8 @@ TutorialUserRenewQualification: Renew qualification
 TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"}
 CommTutorial: Course message
+TutorialDrivingPermit: Driving permit
+TutorialEyeExam: Eye exam
+TutorialNote: Course note
+TutorialDayAttendance day: Attendance #{day}
+TutorialDayNote day: Attendance note #{day}

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

@@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Bitte in sowohl deutscher als auch
 SchoolAuthorshipStatementSheetExamDefinition: Eigenständigkeitserklärung für prüfungszugehörige Übungsblattabgaben
 SchoolAuthorshipStatementSheetExamDefinitionTip: Bitte in sowohl deutscher als auch englischer Sprache angeben.
 SchoolAuthorshipStatementSheetAllowOther: Abweichende Eigenständigkeitserklärungen für nicht-prüfungszugehörige Übungsblätter erlauben?
-SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
+SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben?
+
+DailyActDummy: Platzhalter ohne Funktion

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

@@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Please enter both german and englis
 SchoolAuthorshipStatementSheetExamDefinition: Statement of Authorship for exam-related exercise sheets
 SchoolAuthorshipStatementSheetExamDefinitionTip: Please enter both german and english statements.
 SchoolAuthorshipStatementSheetAllowOther: Allow adaptations for exam-unrelated exercise sheets?
-SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
+SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets?
+
+DailyActDummy: Placholder without function

messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg

@@ -20,3 +20,7 @@ ExceptionNoOccurAt: Termin
 ExceptionKind: Termin ...
 ExceptionKindOccur: Findet statt
 ExceptionKindNoOccur: Findet nicht statt
+DayNext: Folgetag
+DayPrev: Vortag
+WeekNext: Nächste Woche 
+WeekPrev: Vorherige Woche

messages/uniworx/utils/handler_form/occurrences/en-eu.msg

@@ -20,3 +20,7 @@ ExceptionNoOccurAt: Event
 ExceptionKind: Event ...
 ExceptionKindOccur: Does occur
 ExceptionKindNoOccur: Does not occur
+DayNext: Next day
+DayPrev: Previous day
+WeekNext: Next week
+WeekPrev: Previous week

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

@@ -97,6 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen
 MenuLecturerInvite: Funktionäre hinzufügen
 MenuSchoolList: Bereiche
 MenuSchoolNew: Neuen Bereich anlegen
+MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht
 MenuExternalExamGrades: Prüfungsleistungen
 MenuExternalExamUsers: Teilnehmer:innen
 MenuExternalExamEdit: Bearbeiten

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

@@ -97,6 +97,7 @@ MenuExamOfficeUsers: Users
 MenuLecturerInvite: Add functionaries
 MenuSchoolList: Departments
 MenuSchoolNew: Create new department
+MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day
 MenuExternalExamGrades: Exam results
 MenuExternalExamUsers: Participants
 MenuExternalExamEdit: Edit

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@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>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -48,11 +48,11 @@ TableNotPassed: Nicht bestanden
 TableTutorialTutors: Ausbilder
 TableTutorialName: Bezeichnung
 TableTutorialType: Art
-TableTutorialRoom: Regulärer Raum
+TableTutorialRoom: Raum
 TableTutorialRoomHidden: Raum nur für Teilnehmer
 TableTutorialRoomIsUnset !ident-ok: —
 TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt
-TableTutorialTime: Zeit
+TableTutorialOccurrence: Termin
 TableTutorialDeregisterUntil: Abmeldungen bis
 TableTutorialFirstDay: Starttag
 TableActionsHead: Aktionen
@@ -80,6 +80,7 @@ TableCompanyFilter: Firma oder Nummer
 TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
 TablePrimeCompany: Primäre Firma
+TableBookingCompany: Buchende Firma
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger
@@ -98,6 +99,7 @@ TableCompanyNrRerouteActive: Aktive Umleitungen
 TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
+TableSupervisorActive: Aktiver Ansprechpartner
 TableSupervisee: Ansprechpartner für
 TableReason: Begründung
 TableCreationTime: Erstellungszeit
@@ -115,4 +117,5 @@ TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe
 TableFilterCommaName: Mehrere Namen mit Komma trennen.
 TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
 TableUserEdit: Benutzer bearbeiten
-TableRows: Zeilen
+TableRows: Zeilen
+TableUserParkingToken: Parkmarke

messages/uniworx/utils/table_column/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -48,14 +48,14 @@ TableNotPassed: Failed
 TableTutorialTutors: Instructors
 TableTutorialName: Name
 TableTutorialType: Type
-TableTutorialRoom: Regular room
+TableTutorialRoom: Room
 TableTutorialRoomHidden: Room only for participants
 TableTutorialRoomIsUnset: —
 TableTutorialRoomIsHidden: Room is only displayed to participants
 TableTutorialDeregisterUntil: Deregister until
 TableTutorialFirstDay: Start date
 TableActionsHead: Actions
-TableTutorialTime: Time
+TableTutorialOccurrence: Session
 TableNoFilter: No restriction
 TableUserMatriculation: AVS number
 TableColumnStudyFeatures: Features of study
@@ -80,6 +80,7 @@ TableCompanyFilter: Company/Nr
 TableCompanyShort: Company shorthand
 TableCompanies: Companies
 TablePrimeCompany: Primary company
+TableBookingCompany: Booking company
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
 TableCompanyUser: Associate
@@ -98,6 +99,7 @@ TableCompanyNrRerouteActive: Active reroutes
 TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
+TableSupervisorActive: Active supervisor
 TableSupervisee: Supervisor for
 TableReason: Reason
 TableCreationTime: Creation
@@ -115,4 +117,5 @@ TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
 TableFilterCommaName: Separate names by comma.
 TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
 TableUserEdit: Edit user
-TableRows: Rows
+TableRows: Rows
+TableUserParkingToken: Parking token

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

@@ -91,6 +91,7 @@ UtilExamResultVoided: Entwertet
 CourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName !ident-ok: #{tid} - #{ssh} - #{csh}: #{coursen}
 RoomReferenceNone !ident-ok: —
 RoomReferenceSimple !ident-ok: Text
+RoomReferenceSimpleAt r@Text: in Raum #{r}
 RoomReferenceLink: Link & Anweisungen
 RoomReferenceSimpleText: Raum
 RoomReferenceSimpleTextPlaceholder: Raum

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

@@ -91,6 +91,7 @@ UtilExamResultVoided: Voided
 CourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen}
 RoomReferenceNone: —
 RoomReferenceSimple: Text
+RoomReferenceSimpleAt r: at room #{r}
 RoomReferenceLink: Link & Instructions
 RoomReferenceSimpleText: Room
 RoomReferenceSimpleTextPlaceholder: Room

models/courses.model

@@ -28,13 +28,12 @@ Course    -- Information about a single course; contained info is always visible
     TermSchoolCourseName   term school name         -- name must be unique within school and semester
     deriving Generic
 CourseEvent
-    type (CI Text)
-    course CourseId OnDeleteCascade OnUpdateCascade
-    room RoomReference Maybe
-    roomHidden Bool default=false
-    time Occurrences
-    note StoredMarkup Maybe
-    lastChanged UTCTime default=now()
+    type            (CI Text)
+    course          CourseId OnDeleteCascade OnUpdateCascade    
+    roomHidden      Bool default=false
+    time            (JSONB Occurrences)
+    note            StoredMarkup Maybe
+    lastChanged     UTCTime default=now()
     deriving Generic
 
 CourseAppInstructionFile

models/lms.model

@@ -24,7 +24,7 @@ Qualification
     -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
     -- UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique 
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
-  deriving Show Eq Generic
+  deriving Show Eq Generic Binary
 
 -- TODOs:
 --  - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?

models/tutorials.model

@@ -6,10 +6,9 @@ Tutorial json
     name            TutorialName
     course          CourseId OnDeleteCascade OnUpdateCascade
     type            (CI Text) -- "Tutorium", "Zentralübung", ...
-    capacity        Int Maybe -- limit for enrolment in this tutorial
-    room            RoomReference Maybe
+    capacity        Int Maybe -- limit for enrolment in this tutorial    
     roomHidden      Bool default=false
-    time            Occurrences
+    time            (JSONB Occurrences)
     regGroup        (CI Text) Maybe -- each participant may register for one tutorial per regGroup
     registerFrom    UTCTime Maybe
     registerTo      UTCTime Maybe
@@ -25,8 +24,19 @@ Tutor
     UniqueTutor tutorial user
     deriving Generic
 TutorialParticipant
-    tutorial    TutorialId OnDeleteCascade OnUpdateCascade
-    user        UserId
+    tutorial        TutorialId OnDeleteCascade OnUpdateCascade
+    user            UserId
+    company         CompanyId Maybe
+    drivingPermit   UserDrivingPermit Maybe
+    eyeExam         UserEyeExam Maybe
+    note            Text Maybe
     UniqueTutorialParticipant tutorial user
-    deriving Eq Ord Show
-    deriving Generic
+    deriving Eq Ord Show Generic
+TutorialParticipantDay
+    tutorial        TutorialId  OnDeleteCascade OnUpdateCascade
+    user            UserId      OnDeleteCascade OnUpdateCascade
+    day             Day
+    attendance      Bool default=true
+    note            Text Maybe
+    UniqueTutorialParticipantDay tutorial user day
+    deriving Show Generic

models/users.model

@@ -104,4 +104,9 @@ UserSupervisor
     reason                Text      Maybe -- miscellaneous reason, e.g. Winterservice supervisision
     UniqueUserSupervisor supervisor user  -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
     deriving Generic Show
-    
+UserDay
+    user                  UserId    OnDeleteCascade OnUpdateCascade
+    day                   Day
+    parkingToken          Bool      default=false
+    UniqueUserDay user day
+    deriving Generic Show

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.79"
+  "version": "27.4.76"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.79",
+  "version": "27.4.76",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.79",
+  "version": "27.4.76",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.79
+version: 27.4.76
 dependencies:
   - base
   - yesod
@@ -256,7 +256,7 @@ ghc-options:
   - -fno-warn-unrecognised-pragmas
   - -fno-warn-partial-type-signatures
   - -fno-max-relevant-binds
-  - -j
+  - -j5
   - -freduction-depth=0
   - -fprof-auto-calls
   - -g

routes

@@ -153,11 +153,11 @@
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET          !free
 
 
-/school                    SchoolListR         GET
+/school                    SchoolListR         GET             !free
 !/school/new               SchoolNewR          GET POST
 /school/#SchoolId          SchoolR:
-  /                        SchoolEditR         GET POST
-
+  /edit                      SchoolEditR       GET POST
+  /day/#Day                  SchoolDayR        GET POST
 
 /participants                   ParticipantsListR GET            !evaluation
 /participants/#TermId/#SchoolId ParticipantsR     GET            !evaluation

src/Application.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@tcs.ifi.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@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -115,13 +115,8 @@ import GHC.RTS.Flags (getRTSFlags)
 
 import qualified Prometheus
 
-import qualified Data.IntervalMap.Strict as IntervalMap
-
 import qualified Utils.Pool as Custom
 
-import Utils.Postgresql
-import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
-
 import qualified System.Clock as Clock
 
 import Utils.Avs (mkAvsQuery)
@@ -137,6 +132,7 @@ import Handler.Users.Add
 import Handler.Admin
 import Handler.Term
 import Handler.School
+import Handler.School.DayTasks
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
@@ -218,18 +214,6 @@ makeFoundation appSettings''@AppSettings{..} = do
     appJobState <- liftIO newEmptyTMVarIO
     appHealthReport <- liftIO $ newTVarIO Set.empty
 
-    appFileSourceARC <- for appFileSourceARCConf $ \ARCConf{..} -> do
-      ah <- initARCHandle arccMaximumGhost arccMaximumWeight
-      void . Prometheus.register $ arcMetrics ARCFileSource ah
-      return ah
-    appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do
-      lh <- initLRUHandle precMaximumWeight
-      void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh
-      return lh
-    appFileInjectInhibit <- liftIO $ newTVarIO IntervalMap.empty
-    for_ (guardOnM (isn't _JobsOffload appJobMode) appInjectFiles) $ \_ ->
-      void . Prometheus.register $ injectInhibitMetrics appFileInjectInhibit
-
     appStartTime <- liftIO getCurrentTime
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
@@ -238,7 +222,7 @@ makeFoundation appSettings''@AppSettings{..} = do
     -- from there, and then create the real foundation.
     let
       mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
-      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
+      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
       tempFoundation = mkFoundation
         (error "appSettings' forced in tempFoundation")
         (error "connPool forced in tempFoundation")
@@ -251,7 +235,6 @@ makeFoundation appSettings''@AppSettings{..} = do
         (error "JSONWebKeySet forced in tempFoundation")
         (error "ClusterID forced in tempFoundation")
         (error "memcached forced in tempFoundation")
-        (error "memcachedLocal forced in tempFoundation")
         (error "MinioConn forced in tempFoundation")
         (error "VerpSecret forced in tempFoundation")
         (error "AuthKey forced in tempFoundation")
@@ -336,12 +319,6 @@ makeFoundation appSettings''@AppSettings{..} = do
           $logWarnS "setup" "Clearing memcached"
           liftIO $ Memcached.flushAll memcachedConn
         return AppMemcached{..}
-      appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do
-        memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight
-        void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC
-        memcachedLocalInvalidationQueue <- newTVarIO mempty
-        memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue
-        return AppMemcachedLocal{..}
 
       appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool
 
@@ -379,7 +356,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       $logDebugS "Runtime configuration" $ tshowCrop appSettings'
 
-      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
+      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
 
       -- Return the foundation
       $logInfoS "setup" "*** DONE ***"

src/Database/Esqueleto/Utils.hs

@@ -49,7 +49,6 @@ module Database.Esqueleto.Utils
   , unKey
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
-  , selectMaybe
   , str2text, str2text'
   , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
@@ -739,8 +738,9 @@ selectCountDistinct q = do
     _other
       -> error "E.countDistinct did not return exactly one result"
 
-selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
-selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
+-- DEPRECATED: use Database.Esqueleto.selectOne instead
+-- 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)

src/Database/Esqueleto/Utils/TH.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH
   , sqlInTuple, sqlInTuples
   , _unValue
   , unValueN, unValueNIs
-  , sqlIJproj, sqlLOJproj, sqlFOJproj
+  , sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj'
   ) where
 
 import ClassyPrelude
@@ -26,6 +26,9 @@ import Data.List (foldr1, foldl)
 import Utils.TH
 import Control.Lens.Iso (Iso', iso)
 
+{-# ANN module ("HLint: ignore Redundant bracket"::String) #-}
+
+
 class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
   sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
 
@@ -99,7 +102,7 @@ unValueNIs arity uvIdx = do
 -- | Generic projections for InnerJoin-tuples
 --   gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
 --
---   > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
+--   > $(sqlIJproj n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
 sqlIJproj :: Int -> Int -> ExpQ
 sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
 
@@ -108,3 +111,23 @@ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
 
 sqlFOJproj :: Int -> Int -> ExpQ
 sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
+
+-- | Generic projections for Join-tuple
+--   gives i-th element of n-tuple of left-associative join pairs, i.e.
+--
+--   > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3
+sqlMIXproj :: String -> Int -> ExpQ
+sqlMIXproj = leftAssociativeProjection . map decodeJoin
+  where
+    decodeJoin 'I' = 'E.InnerJoin
+    decodeJoin 'L' = 'E.LeftOuterJoin
+    decodeJoin 'R' = 'E.RightOuterJoin
+    decodeJoin 'F' = 'E.FullOuterJoin
+    decodeJoin 'O' = 'E.FullOuterJoin
+    decodeJoin 'X' = 'E.CrossJoin
+    decodeJoin 'C' = 'E.CrossJoin
+    decodeJoin  c  = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\""  -- always raised at compile time, so this is ok
+
+--  Alternative using `reify`; works, but may require `$(return [])` between type definition and call to workaround ghc staging problems
+sqlMIXproj' :: Name -> Int -> ExpQ
+sqlMIXproj' t i = extractConstructorNames t >>= flip leftAssociativeProjection i

src/Database/Persist/Types/Instances.hs

@@ -27,7 +27,7 @@ instance Hashable LiteralType
 instance Binary LiteralType
 instance NFData LiteralType
 
-  
+
 deriving instance Generic PersistValue
 
 instance Hashable PersistValue

src/Foundation/Authorization.hs

@@ -38,7 +38,7 @@ import Handler.Utils.I18n
 import Handler.Utils.Routes
 import Utils.Course (courseIsVisible)
 import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
-  
+
 import qualified Data.Set as Set
 import qualified Data.Aeson as JSON
 import qualified Data.HashSet as HashSet
@@ -95,7 +95,7 @@ instance Exception InvalidAuthTag
 
 
 type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-  
+
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
   | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
@@ -174,7 +174,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
       v <- mkV
       memcachedBySet mExp k v
       either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v
- 
+
 -- cacheAP' :: ( Binary k
 --             , Typeable v, Binary v
 --             )
@@ -185,7 +185,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
 -- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
 --   Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
 --   Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
-  
+
 cacheAPDB' :: ( Binary k
               , Typeable v, Binary v, NFData v
               )
@@ -313,7 +313,8 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
 
       dnf <- throwLeft $ routeAuthTags currentRoute
       let eval :: forall m''. MonadAP m'' => AuthTagsEval m''
-          eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
+          -- eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
+          eval dnf' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf')
        in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
 
       return False
@@ -368,7 +369,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
         noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
 
         eval :: forall m'. MonadAP m' => AuthTagsEval m'
-        eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
+        -- eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
+        eval dnf' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf')
 
       bearerAuthority' <- hoist apRunDB $ do
         bearerAuthority' <- flip foldMapM bearerAuthority $ \case
@@ -538,14 +540,14 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d
         guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
         return Authorized
 
-tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of 
+tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
     ForProfileR     cID -> checkSupervisor        (mAuthId, cID)
     ForProfileDataR cID -> checkSupervisor        (mAuthId, cID)
     FirmAllR            -> checkAnySupervisor      mAuthId
     FirmUsersR      fsh -> checkCompanySupervisor (mAuthId, fsh)
     FirmSupersR     fsh -> checkCompanySupervisor (mAuthId, fsh)
-    r -> $unsupportedAuthPredicate AuthSupervisor r    
-  where 
+    r -> $unsupportedAuthPredicate AuthSupervisor r
+  where
     checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do
       authId <- maybeExceptT AuthenticationRequired $ return mAuthId
       uid <- decrypt cID
@@ -553,13 +555,13 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
       guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor)
       return Authorized
     checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
-      authId <- maybeExceptT AuthenticationRequired $ return mAuthId      
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
       -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
       isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True]
       guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
       return Authorized
     checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do
-      authId <- maybeExceptT AuthenticationRequired $ return mAuthId      
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
       isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId]
       guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor)
       return Authorized
@@ -692,7 +694,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
       CourseR{} -> unauthorizedI MsgUnauthorizedLecturer
       EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer
-      _other -> unauthorizedI MsgUnauthorizedSchoolLecturer 
+      _other -> unauthorizedI MsgUnauthorizedSchoolLecturer
   | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
       CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
          authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -722,7 +724,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture
          return Authorized
   where
     mkLecturerList _ route _ = case route of
-      CourseR{} -> cacheLecturerList 
+      CourseR{} -> cacheLecturerList
       EExamR{} -> Just
         ( AuthCacheExternalExamStaffList
         , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
@@ -1199,7 +1201,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case rout
     guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam
     return Authorized
   CSheetR tid ssh csh shn _ -> exceptT return return $ do
-    requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do
+    requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectOne . E.from $ \(course `E.InnerJoin` sheet) -> do
       E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
       E.where_ $ course E.^. CourseTerm      E.==. E.val tid
            E.&&. course E.^. CourseSchool    E.==. E.val ssh
@@ -1700,7 +1702,7 @@ evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -
 evalAccessWith assumptions route isWrite = do
   mAuthId <- liftHandler maybeAuthId
   evalAccessWithFor assumptions mAuthId route isWrite
-  
+
 evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
 evalAccessWithDB = evalAccessWith
 

src/Foundation/Navigation.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 <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -144,11 +144,15 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck       $ Just PrintCenter
 breadcrumb PrintLogR        = i18nCrumb MsgMenuPrintLog       $ Just PrintCenterR
 
 breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
-breadcrumb (SchoolR ssh sRoute) = case sRoute of
-  SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
+breadcrumb (SchoolR ssh SchoolEditR) =
+  useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
     School{..} <- MaybeT $ get ssh
     isAdmin <- lift $ hasReadAccessTo SchoolListR
     return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
+breadcrumb (SchoolR ssh (SchoolDayR d)) = do
+    dt <- formatTime SelFormatDate d
+    mr <- getMessageRender
+    return (mr $ MsgMenuSchoolDay ssh dt, Just SchoolListR)
 breadcrumb SchoolNewR       = i18nCrumb MsgMenuSchoolNew        $ Just SchoolListR
 
 breadcrumb (ExamOfficeR EOExamsR)  = i18nCrumb MsgMenuExamOfficeExams    Nothing
@@ -937,19 +941,37 @@ pageActions :: ( MonadHandler m
                , MonadUnliftIO m
                )
             => Route UniWorX -> m [Nav]
-pageActions NewsR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuOpenCourses
-      , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
-      , navAccess'     = NavAccessTrue
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+pageActions NewsR = do
+  now <- liftIO getCurrentTime
+  let nowaday = utctDay now
+  nd <- formatTime SelFormatDate now
+  schools <- useRunDB $ selectList [] [Asc SchoolShorthand]
+  return $
+    ( NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuOpenCourses
+        , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
       }
-    , navChildren = []
-    }
-  ]
+    ) :
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSchoolDay ssh nd
+        , navRoute       = SchoolR ssh $ SchoolDayR nowaday
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    | sch <- schools, let ssh = sch ^. _entityKey
+    ]
 pageActions (CourseR tid ssh csh CShowR) = do
   materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
   tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR
@@ -1179,6 +1201,13 @@ pageActions SchoolListR = return
     , navChildren = []
     }
   ]
+pageActions (SchoolR ssh (SchoolDayR nd)) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink msg $ SchoolR ssh (SchoolDayR $ addDays n nd)
+    , navChildren = []
+    }
+  | (msg, n) <- [(MsgWeekPrev, -7), (MsgDayPrev, -1), (MsgDayNext, 1), (MsgWeekNext, 7)]
+  ]
 pageActions UsersR = return
   [ NavPageActionPrimary
     { navLink = NavLink
@@ -1959,7 +1988,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do
         { navLabel       = MsgMenuSheetPersonalisedFiles
         , navRoute       = CSheetR tid ssh csh shn SPersonalFilesR
         , navAccess'     = NavAccessDB $
-            let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
+            let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectOne . E.from $ \(sheet `E.InnerJoin` course) -> do
                   E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
                   E.where_$ sheet E.^. SheetName E.==. E.val shn
                       E.&&. course E.^. CourseTerm E.==. E.val tid
@@ -2561,7 +2590,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) .
   E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
 
   E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
-       E.&&. sheet E.^. SheetName E.==. E.val shn
+       E.&&. sheet  E.^. SheetName E.==. E.val shn
        E.&&. course E.^. CourseShorthand E.==. E.val csh
        E.&&. course E.^. CourseTerm E.==. E.val tid
 

src/Foundation/Type.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,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
 
@@ -11,8 +11,6 @@ module Foundation.Type
   , _SessionStorageMemcachedSql, _SessionStorageAcid
   , AppMemcached(..)
   , _memcachedKey, _memcachedConn
-  , AppMemcachedLocal(..)
-  , _memcachedLocalARC
   , SMTPPool
   , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
   , DB, DBRead, Form, MsgRenderer, MailM, DBFile
@@ -32,15 +30,10 @@ import qualified Jose.Jwk as Jose
 import qualified Database.Memcached.Binary.IO as Memcached
 import Network.Minio (MinioConn)
 
-import Data.IntervalMap.Strict (IntervalMap)
-
 import qualified Utils.Pool as Custom
 
 import Utils.Metrics (DBConnUseState)
 
-import qualified Data.ByteString.Lazy as Lazy
-import Data.Time.Clock.POSIX (POSIXTime)
-import GHC.Fingerprint (Fingerprint)
 import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
 
 import Utils.Avs (AvsQuery())
@@ -62,13 +55,6 @@ data AppMemcached = AppMemcached
 
 makeLenses_ ''AppMemcached
 
-data AppMemcachedLocal = AppMemcachedLocal
-  { memcachedLocalARC :: ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime)
-  , memcachedLocalHandleInvalidations :: Async ()
-  , memcachedLocalInvalidationQueue :: TVar (Seq (Fingerprint, Lazy.ByteString))
-  } deriving (Generic)
-
-makeLenses_ ''AppMemcachedLocal
 
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -93,13 +79,9 @@ data UniWorX = UniWorX
     , appJSONWebKeySet     :: Jose.JwkSet
     , appHealthReport      :: TVar (Set (UTCTime, HealthReport))
     , appMemcached         :: Maybe AppMemcached
-    , appMemcachedLocal    :: Maybe AppMemcachedLocal
     , appUploadCache       :: Maybe MinioConn
     , appVerpSecret        :: VerpSecret
     , appAuthKey           :: Auth.Key
-    , appFileSourceARC     :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
-    , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
-    , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
     , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
     , appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache
     , appStartTime         :: UTCTime -- for Status Page

src/Handler/Admin.hs

@@ -39,10 +39,6 @@ import Handler.Admin.Crontab as Handler.Admin
 import Handler.Admin.Avs as Handler.Admin
 import Handler.Admin.Ldap as Handler.Admin
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
 
 -- Types and Template Haskell
 data ProblemTableAction = ProblemTableMarkSolved
@@ -368,22 +364,22 @@ mkProblemLogTable = do
       , sortable (Just "solved")  (i18nCell MsgAdminProblemSolved)  $ \(   view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
       , sortable (Just "solver")  (i18nCell MsgAdminProblemSolver)  $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       ]
-    dbtSorting = mconcat
-      [ single ("time"  , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
-      , single ("info"  , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
-      -- , single ("firm"  , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
-      , single ("firm"  , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
-      , single ("user"  , sortUserNameBareM queryUser)
-      , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
-      , single ("solver", sortUserNameBareM querySolver)
+    dbtSorting = Map.fromList
+      [ ("time"  , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
+      , ("info"  , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
+      -- , ("firm"  , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
+      , ("firm"  , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
+      , ("user"  , sortUserNameBareM queryUser)
+      , ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
+      , ("solver", sortUserNameBareM querySolver)
       ]
-    dbtFilter = mconcat
-      [ single ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
-      , single ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
-      , single ("company" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
-      , single ("solved"  , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
-      -- , single ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
-      , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
+    dbtFilter = Map.fromList
+      [ ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
+      , ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
+      , ("company" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
+      , ("solved"  , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
+      -- , ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
+      , ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
           ifNothingM criterion True $ \(crit::Text) -> do
             let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
             protxt <- adminProblem2Text problem
@@ -398,9 +394,9 @@ mkProblemLogTable = do
       , prismAForm (singletonFilter "solved"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
       ]
     acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
-    acts = mconcat
-      [ singletonMap ProblemTableMarkSolved   $ pure ProblemTableMarkSolvedData
-      , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData
+    acts = Map.fromList
+      [ (ProblemTableMarkSolved   , pure ProblemTableMarkSolvedData)
+      , (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData)
       ]
     dbtParams = DBParamsForm
           { dbParamsFormMethod = POST

src/Handler/Admin/Avs.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
 
@@ -38,10 +38,6 @@ import qualified Database.Esqueleto.Utils        as E
 -- import Database.Esqueleto.Utils.TH
 
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
 exceptionWgt :: SomeException -> Widget
 exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
 
@@ -692,23 +688,23 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
                                                                                    ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
         , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
         ]
-      dbtSorting = mconcat
-        [ single $ sortUserNameLink queryUser
-        , single ("avspersonno"   , SortColumn          $ queryUserAvs        >>> (E.^. UserAvsNoPerson))
-        , single ("qualification" , SortColumn          $ queryQualification  >>> (E.?. QualificationShorthand))
-        , single $ sortUserCompany queryUser
-        , single ("valid-until"   , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
-        , single ("last-refresh"  , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserLastRefresh))
-        , single ("first-held"    , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserFirstHeld))
-        , single ("blocked"       , SortColumnNeverNull $ queryQualBlock      >>> (E.?. QualificationUserBlockFrom))
-        , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser       >>> (E.?. QualificationUserScheduleRenewal))
-        -- , single ("validity"      , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
+      dbtSorting = Map.fromList
+        [ sortUserNameLink queryUser
+        , ("avspersonno"   , SortColumn          $ queryUserAvs        >>> (E.^. UserAvsNoPerson))
+        , ("qualification" , SortColumn          $ queryQualification  >>> (E.?. QualificationShorthand))
+        , sortUserCompany queryUser
+        , ("valid-until"   , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
+        , ("last-refresh"  , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserLastRefresh))
+        , ("first-held"    , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserFirstHeld))
+        , ("blocked"       , SortColumnNeverNull $ queryQualBlock      >>> (E.?. QualificationUserBlockFrom))
+        , ("schedule-renew", SortColumnNullsInv  $ queryQualUser       >>> (E.?. QualificationUserScheduleRenewal))
+        -- , ("validity"      , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
         ]
 
-      dbtFilter = mconcat
-        [ single $ fltrUserNameEmail   queryUser
-        , single ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
-        , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+      dbtFilter = Map.fromList
+        [ fltrUserNameEmail   queryUser
+        , ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
+        , ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@@ -1004,15 +1000,15 @@ getProblemAvsErrorR = do
           E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
           E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
           return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
-        qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
-        qerryUsrAvs   = $(E.sqlIJproj 2 1)
-        qerryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
-        qerryUser     = $(E.sqlIJproj 2 2)
+        querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
+        querryUsrAvs   = $(E.sqlIJproj 2 1)
+        querryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
+        querryUser     = $(E.sqlIJproj 2 2)
         reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
         reserrUsrAvs  = _dbrOutput . _1
         -- reserrUser   :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
         -- reserrUser    = _dbrOutput . _2
-        dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
+        dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat
           [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
@@ -1025,15 +1021,15 @@ getProblemAvsErrorR = do
           , sortable (Just "avs-last-error")  (i18nCell MsgLastAvsSynchError)
               $ cellMaybe textCell  . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
           ]
-        dbtSorting = mconcat
-          [ single (sortUserNameLink qerryUser)
-          , single ("avs-nr"        , SortColumn          $ qerryUsrAvs >>> (E.^. UserAvsNoPerson))
-          , single ("avs-last-synch", SortColumnNullsInv  $ qerryUsrAvs >>> (E.^. UserAvsLastSynch))
-          , single ("avs-last-error", SortColumn          $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError))
+        dbtSorting = Map.fromList
+          [  sortUserNameLink querryUser
+          , ("avs-nr"        , SortColumn          $ querryUsrAvs >>> (E.^. UserAvsNoPerson))
+          , ("avs-last-synch", SortColumnNullsInv  $ querryUsrAvs >>> (E.^. UserAvsLastSynch))
+          , ("avs-last-error", SortColumn          $ querryUsrAvs >>> (E.^. UserAvsLastSynchError))
           ]
-        dbtFilter = mconcat
-          [ single $ fltrUserNameEmail qerryUser
-          , single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError))
+        dbtFilter = Map.fromList
+          [ fltrUserNameEmail querryUser
+          , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError))
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgLmsUser mPrev

src/Handler/CommCenter.hs

@@ -25,11 +25,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import Database.Esqueleto.Utils.TH
 
 
--- 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)
 
@@ -119,12 +114,12 @@ mkCCTable = do
           , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
           ]
       ]
-    dbtFilter = mconcat
-      [ single ("sent"      , FilterColumn . E.mkDayFilterTo
-                                $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
-      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
-                                $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
-      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+    dbtFilter = Map.fromList
+      [ ("sent"      , FilterColumn . E.mkDayFilterTo
+                  $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
+      , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                  $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
+      , ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus Just
                                 $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
                                                      ,E.str2text' $ queryMail  row E.?. SentMailHeaders  ])
       ]

src/Handler/Course/Edit.hs

@@ -452,6 +452,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
                     void $ upsertCourseQualifications aid cid $ cfQualis res
                     insert_ $ CourseEdit aid now cid
+                    memcachedFlushClass MemcachedKeyClassTutorialOccurrences
                     memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True

src/Handler/Course/Events/Delete.hs

@@ -31,10 +31,8 @@ postCEvDeleteR tid ssh csh cID = do
       [whamlet|
         $newline never
         #{courseEventType}
-        $maybe room <- courseEventRoom
-          , #{roomReferenceText room}
         :
-        ^{occurrencesWidget courseEventTime}
+        ^{occurrencesWidget False courseEventTime}
       |]
 
     drRecordConfirmString :: Entity CourseEvent -> DB Text

src/Handler/Course/Events/Edit.hs

@@ -26,9 +26,8 @@ postCEvEditR tid ssh csh cID = do
       replace eId CourseEvent
         { courseEventCourse
         , courseEventType = cefType
-        , courseEventRoom = cefRoom
         , courseEventRoomHidden = cefRoomHidden
-        , courseEventTime = cefTime
+        , courseEventTime = cefTime & JSONB
         , courseEventNote = cefNote
         , courseEventLastChanged = now
         }

src/Handler/Course/Events/Form.hs

@@ -17,7 +17,6 @@ import qualified Database.Esqueleto.Legacy as E
 
 data CourseEventForm = CourseEventForm
   { cefType             :: CI Text
-  , cefRoom             :: Maybe RoomReference
   , cefRoomHidden       :: Bool
   , cefTime             :: Occurrences
   , cefNote             :: Maybe StoredMarkup
@@ -37,14 +36,12 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
   let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
 
   cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
-  cefRoom' <- aFormToWForm $ roomReferenceFormOpt (fslI MsgCourseEventRoom) (cefRoom <$> template)
   cefRoomHidden' <- wpopt checkBoxField (fslI MsgCourseEventRoomHidden & setTooltip MsgCourseEventRoomHiddenTip) (cefRoomHidden <$> template)
   cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
   cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template)
 
   return $ CourseEventForm
     <$> cefType'
-    <*> cefRoom'
     <*> cefRoomHidden'
     <*> cefTime'
     <*> cefNote'
@@ -52,8 +49,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
 courseEventToForm :: CourseEvent -> CourseEventForm
 courseEventToForm CourseEvent{..} = CourseEventForm
   { cefType = courseEventType
-  , cefRoom = courseEventRoom
   , cefRoomHidden = courseEventRoomHidden
-  , cefTime = courseEventTime
+  , cefTime = courseEventTime & unJSONB
   , cefNote = courseEventNote
   }

src/Handler/Course/Events/New.hs

@@ -24,9 +24,8 @@ postCEventsNewR tid ssh csh = do
       eId <- insert CourseEvent
         { courseEventCourse      = cid
         , courseEventType        = cefType
-        , courseEventRoom        = cefRoom
         , courseEventRoomHidden  = cefRoomHidden
-        , courseEventTime        = cefTime
+        , courseEventTime        = cefTime & JSONB
         , courseEventNote        = cefNote
         , courseEventLastChanged = now
         }

src/Handler/Course/ParticipantInvite.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -13,6 +13,7 @@ import Import
 
 import Handler.Utils
 import Handler.Utils.Avs
+import Handler.Utils.Company
 
 import Jobs.Queue
 
@@ -49,15 +50,15 @@ tutorialTemplateNames Nothing     = ["Vorlage", "Template"]
 tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
 
 tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
-tutorialDefaultName Nothing     = formatDayForTutName 
-tutorialDefaultName (Just ttyp) = 
+tutorialDefaultName Nothing     = formatDayForTutName
+tutorialDefaultName (Just ttyp) =
   let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
   in  (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
 
 formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
 -- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
-formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow 
-  where 
+formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
+  where
     d2u '-' = '_'
     d2u  c  =  c
 
@@ -151,7 +152,7 @@ instance Monoid AddParticipantsResult where
 
 getCAddUserR,  postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCAddUserR = postCAddUserR
-postCAddUserR tid ssh csh = do 
+postCAddUserR tid ssh csh = do
   today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
   handleAddUserR tid ssh csh (Right today) Nothing
   -- postTAddUserR tid ssh csh (CI.mk $ tshow today)  -- Don't use user date display setting, so that tutorial default names conform to all users
@@ -163,8 +164,8 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
 
 
 handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
-handleAddUserR tid ssh csh tdesc ttyp = do 
-  (cid, tutTypes, tutNameSuggestions) <- runDB $ do 
+handleAddUserR tid ssh csh tdesc ttyp = do
+  (cid, tutTypes, tutNameSuggestions) <- runDB $ do
     let plainTemplates = tutorialTemplateNames Nothing
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     tutTypes <- E.select $ E.distinct $ do
@@ -176,9 +177,9 @@ handleAddUserR tid ssh csh tdesc ttyp = do
     let typeSet = Set.fromList  [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
                                 | temp <- plainTemplates
                                 , let temp_sep = CI.original (temp <> tutorialTypeSeparator)
-                                , E.Value t <- tutTypes                    
+                                , E.Value t <- tutTypes
                                 ]
-    tutNames <- E.select $ do 
+    tutNames <- E.select $ do
       tutorial <- E.from $ E.table @Tutorial
       let tuName = tutorial E.^. TutorialName
       E.where_ $  tutorial E.^. TutorialCourse E.==. E.val cid
@@ -192,23 +193,23 @@ handleAddUserR tid ssh csh tdesc ttyp = do
 
   currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
 
-  (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm    
+  (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm
   --   $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
-  prefillUsers <- case registerConfirmResult of 
+  prefillUsers <- case registerConfirmResult of
     Nothing -> return mempty
-    (Just BtnCourseRegisterAbort)   -> do 
+    (Just BtnCourseRegisterAbort)   -> do
       addMessageI Warning MsgAborted
       -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome
       confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction  -- ignore any exception, since it is only used to prefill a form field for convenience
       return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
     (Just BtnCourseRegisterConfirm) -> do
-      confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction  
+      confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
       --   $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
       unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
         let
           users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
           tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
-          actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!      
+          actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
         registeredUsers <- registerUsers cid users
         whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
           whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
@@ -218,13 +219,13 @@ handleAddUserR tid ssh csh tdesc ttyp = do
             redirect $ CTutorialR tid ssh csh tName TUsersR
         redirect $ CourseR tid ssh csh CUsersR
       return mempty
-  
+
   ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
     let tutTypesMsg   = [(SomeMessage tt,tt) | tt <- tutTypes]
-        tutDefType    = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)        
+        tutDefType    = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
     auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
     auReqTutorial <- optionalActionW
-      ( (,,) 
+      ( (,,)
         <$> aopt  (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
                   (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
                   (Just $ maybeLeft tdesc)
@@ -349,12 +350,12 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
   existingTut <- getBy $ UniqueTutorial cid newTutorialName
   templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName]
   case (existingTut, newFirstDay, templateEnt) of
-    (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day 
+    (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day
     (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
       Course{..} <- get404 cid
       term <- get404 courseTerm
-      let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
-          newTime     = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime          
+      let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime)
+          newTime     = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime
           dayDiff   = maybe 0 (diffDays moveDay) tutorialFirstDay
           mvTime    = fmap $ addLocalDays dayDiff
           newType0  = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType
@@ -367,13 +368,13 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
           , tutorialCourse          = cid
           , tutorialType            = newType
           , tutorialFirstDay        = newFirstDay
-          , tutorialTime            = newTime
+          , tutorialTime            = newTime & JSONB
           , tutorialRegisterFrom    = mvTime tutorialRegisterFrom
           , tutorialRegisterTo      = mvTime tutorialRegisterTo
           , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
           , tutorialLastChanged     = now
           , ..
-          } [] -- update cannot happen due to previous case      
+          } [] -- update cannot happen due to previous case
       audit $ TransactionTutorialEdit tutId
       return tutId
     _ -> do
@@ -383,9 +384,8 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
           , tutorialCourse          = cid
           , tutorialType            = fromMaybe defaultTutorialType newTutorialType
           , tutorialCapacity        = Nothing
-          , tutorialRoom            = Nothing
           , tutorialRoomHidden      = False
-          , tutorialTime            = Occurrences mempty mempty
+          , tutorialTime            = mempty
           , tutorialRegGroup        = Nothing
           , tutorialRegisterFrom    = Nothing
           , tutorialRegisterTo      = Nothing
@@ -393,7 +393,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
           , tutorialLastChanged     = now
           , tutorialTutorControlled = False
           , tutorialFirstDay        = Nothing
-          } [] -- update cannot happen due to previous cases      
+          } [] -- update cannot happen due to previous cases
       audit $ TransactionTutorialEdit tutId
       return tutId
 
@@ -401,6 +401,10 @@ registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
 registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
   prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
   participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do
+    tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser
+    let tutorialParticipantDrivingPermit = Nothing
+        tutorialParticipantEyeExam       = Nothing
+        tutorialParticipantNote          = Nothing
     Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } []
     audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser
     return tutPartId

src/Handler/Course/Show.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>,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>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -29,7 +29,7 @@ import Handler.Exam.List (mkExamTable)
 
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
-  mbAid <- maybeAuthId  
+  mbAid <- maybeAuthId
   now <- liftIO getCurrentTime
   (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial),courseQualifications) <- runDB . maybeT notFound $ do
     [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
@@ -146,7 +146,7 @@ getCShowR tid ssh csh = do
     | otherwise
       -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
   registrationOpen  <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
-  mayMassRegister   <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR  
+  mayMassRegister   <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
 
   MsgRenderer mr <- getMsgRenderer
 
@@ -154,14 +154,14 @@ getCShowR tid ssh csh = do
     tutorialDBTable = DBTable{..}
       where
         resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial)
-        resultTutorial = _dbrOutput . _1
-        resultShowRoom = _dbrOutput . _2
-        
+        resultTutorial  = _dbrOutput . _1
+        resultHideRoom  = _dbrOutput . _2
+
         dbtSQLQuery tutorial = do
           E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
-          let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid
-                   E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
-          return (tutorial, showRoom)
+          let hideRoom = maybe E.true (E.not__ . flip showTutorialRoom tutorial . E.val) mbAid
+                   E.&&. (tutorial E.^. TutorialRoomHidden)
+          return (tutorial, hideRoom)
         dbtRowKey = (E.^. TutorialId)
         dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId
         dbtColonnade = dbColonnade $ mconcat
@@ -180,10 +180,10 @@ getCShowR tid ssh csh = do
                            <li>
                              ^{nameEmailWidget' tutor}
                      |]
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if
-              | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-              | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
-          , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res ->
+              let roomHidden = res ^. resultHideRoom
+                  ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
+              in occurrencesCell roomHidden ttime
           , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
           , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
           , sortable (Just "deregister-until") (i18nCell MsgTableTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
@@ -220,7 +220,6 @@ getCShowR tid ssh csh = do
           [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
           , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
           , ("first-day", SortColumnNullsInv  $ \tutorial -> tutorial E.^. TutorialFirstDay )
-          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
           , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
           , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
           , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )

src/Handler/Course/User.hs

@@ -444,13 +444,11 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
                     <li>
                       ^{userEmailWidget usr}
               |]
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
-          , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
           ]
         dbtSorting = mconcat
           [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
           , singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName
-          , singletonMap "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom
           , singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
               E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
               E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial

src/Handler/Course/Users.hs

@@ -18,6 +18,7 @@ import Import
 import Utils.Form
 import Handler.Utils
 import Handler.Utils.Course
+import Handler.Utils.Company
 import qualified Database.Esqueleto.Utils       as E
 import qualified Database.Esqueleto.PostgreSQL  as E
 import Database.Esqueleto.Utils.TH
@@ -733,9 +734,12 @@ postCUsersR tid ssh csh = do
         addMessageI Success $ MsgCourseUsersDeregistered nrDel
         redirect $ CourseR tid ssh csh CUsersR
     (CourseUserRegisterTutorialData{..}, selectedUsers) -> do
-        runDB . forM_ selectedUsers $
-          void . insertUnique . TutorialParticipant registerTutorial
-        addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
+        Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do
+          fsh <- selectCompanyUserPrime' uid
+          mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing
+          return $ Sum $ length mbKey
+        let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers
+        addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk
         redirect $ CourseR tid ssh csh CUsersR
     (CourseUserRegisterExamData{..}, selectedUsers) -> do
         Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do

src/Handler/Exam/Form.hs

@@ -23,7 +23,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Utils as E
 
 import qualified Control.Monad.State.Class as State
 import Text.Blaze.Html.Renderer.Text (renderHtml)
@@ -419,7 +419,7 @@ examTemplate cid = runMaybeT $ do
     E.limit 1
     E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
     return (course, exam, authorshipStatementDefinition)
-  
+
   extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []
 
   oldTerm <- MaybeT . get $ courseTerm oldCourse
@@ -517,7 +517,7 @@ validateExam cId oldExam = do
               .| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId)
 
 
-  mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
+  mSchool <- liftHandler . runDB . E.selectOne . E.from $ \(course `E.InnerJoin` school) -> do
     E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
     E.where_ $ course E.^. CourseId E.==. E.val cId
     return school

src/Handler/Firm.hs

@@ -39,10 +39,6 @@ import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
 -- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
 -- decryptUser = decrypt
 
@@ -444,7 +440,7 @@ mkFirmAllTable isAdmin uid = do
                   -- , cmpy & firmCountActiveReroutes'
                   )
         dbtRowKey = (E.^. CompanyId)
-        dbtProj = dbtProjFilteredPostId
+        dbtProj = dbtProjId
         dbtColonnade = formColonnade $ mconcat
           [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
           , sortable (Just "name")          (i18nCell MsgTableCompany)                 $ \(view resultAllCompany -> firm) ->
@@ -482,10 +478,10 @@ mkFirmAllTable isAdmin uid = do
           -- , singletonMap "reroute-act"    $ SortColumn firmCountActiveReroutes
           -- , singletonMap "reroute-all"    $ SortColumn firmCountActiveReroutes'
           ]
-        dbtFilter = mconcat
-          [ single $ fltrCompanyNameNr queryAllCompany
-          , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
-          , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
+        dbtFilter = Map.fromList
+          [ fltrCompanyNameNr queryAllCompany
+          , ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
+          , ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
               (usr :& usrCmp) <- E.from $ E.table @User
                 `E.innerJoin` E.table @UserCompany
                 `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
@@ -496,7 +492,7 @@ mkFirmAllTable isAdmin uid = do
                 )
             )
           -- THIS WAS WAY TOO SLOW:
-          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
           --     (usr :& usrCmp) <- E.from $ E.table @User
           --       `E.leftJoin` E.table @UserCompany
           --       `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@@ -515,7 +511,7 @@ mkFirmAllTable isAdmin uid = do
           --             )
           --       )
           --   )
-          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
           --     usr <- E.from $ E.table @User
           --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
           --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
@@ -536,7 +532,7 @@ mkFirmAllTable isAdmin uid = do
           --           )
           --       )
           --   )
-          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
           --     usr <- E.from $ E.table @User
           --     E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
           --           E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
@@ -553,7 +549,7 @@ mkFirmAllTable isAdmin uid = do
           --               ))
           --       )
           --   )
-          -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
+          -- , ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
           --     case criterion of
           --       Nothing -> E.true
           --       (Just (crit::Text)) -> E.exists $ do
@@ -573,35 +569,35 @@ mkFirmAllTable isAdmin uid = do
           --                       ))
           --               )
           --   )
-          , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
-              case criterion of
-                Nothing -> return True :: DB Bool
-                (Just (crit::Text)) -> do
-                  critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
-                    (usr :& cmp) <- E.from  $ E.table @User `E.innerJoin` E.table @Company
-                      `E.on` (\(usr :& cmp) -> E.exists (do
-                        usrCmp <- E.from $ E.table @UserCompany
-                        E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
-                          E.&&. usrCmp E.^. UserCompanySupervisor
-                          E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
-                      ) E.||. E.exists (do
-                        usrSpr <- E.from $ E.table @UserSupervisor
-                        E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
-                          E.&&. E.exists (do
-                            usrSub <- E.from $ E.table @UserCompany
-                            E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
-                                E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp    E.^. CompanyId
-                          )
-                      ))
-                    E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val        crit )
-                        E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
-                        E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val        crit )
-                    -- E.orderBy [E.asc $ cmp E.^. CompanyId]
-                    return $ cmp E.^. CompanyId
-                  let cid = dbr ^. resultAllCompanyEntity . _entityKey
-                  return $ Set.member cid critFirms
-            )
-          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  -- too slow
+          -- , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- did not work as intended
+          --     case criterion of
+          --       Nothing -> return True :: DB Bool
+          --       (Just (crit::Text)) -> do
+          --         critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:" <> crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
+          --           (usr :& cmp) <- E.from  $ E.table @User `E.innerJoin` E.table @Company
+          --             `E.on` (\(usr :& cmp) -> E.exists (do
+          --               usrCmp <- E.from $ E.table @UserCompany
+          --               E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
+          --                 E.&&. usrCmp E.^. UserCompanySupervisor
+          --                 E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
+          --             ) E.||. E.exists (do
+          --               usrSpr <- E.from $ E.table @UserSupervisor
+          --               E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
+          --                 E.&&. E.exists (do
+          --                   usrSub <- E.from $ E.table @UserCompany
+          --                   E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
+          --                       E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp    E.^. CompanyId
+          --                 )
+          --             ))
+          --           E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val        crit )
+          --               E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
+          --               E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val        crit )
+          --           -- E.orderBy [E.asc $ cmp E.^. CompanyId]
+          --           return $ cmp E.^. CompanyId
+          --         let cid = dbr ^. resultAllCompanyEntity . _entityKey
+          --         return $ Set.member cid critFirms
+          --   )
+          -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  -- too slow
           --     (usr :& usrCmp) <- E.from $ E.table @User
           --       `E.leftJoin` E.table @UserCompany
           --       `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@@ -616,7 +612,16 @@ mkFirmAllTable isAdmin uid = do
           --             )
           --       )
           --   )
-          , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
+          , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
+              (usr :& _usrSpr :& usrCmp) <- E.from $ E.table @User
+                `E.innerJoin` E.table @UserSupervisor `E.on` (\(usr :& usrSpr          ) -> usr    E.^. UserId          E.==. usrSpr E.^. UserSupervisorSupervisor)
+                `E.innerJoin` E.table @UserCompany    `E.on` (\(_   :& usrSpr :& usrCmp) -> usrCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser)
+              E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val criterion)
+                    E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
+                    E.||. (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
+                ) E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
+            )
+          , ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
               (usr :& usrCmp) <- E.from $ E.table @User
                 `E.innerJoin` E.table @UserCompany
                 `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
@@ -626,7 +631,7 @@ mkFirmAllTable isAdmin uid = do
                 ) E.&&. usrCmp E.^. UserCompanySupervisor
                   E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
             )
-          , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
+          , ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
               -- let checkSuper = do -- expensive
               --       usrSpr <- E.from $ E.table @UserSupervisor
               --       E.where_ $ E.notExists (do
@@ -655,8 +660,8 @@ mkFirmAllTable isAdmin uid = do
                 Just True  -> E.exists    checkSuper
                 Just False -> E.notExists checkSuper
             )
-          , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
-          , single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
+          , ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
+          , ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
               (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
                 `E.innerJoin` E.table @QualificationUser
                 `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
@@ -666,15 +671,14 @@ mkFirmAllTable isAdmin uid = do
                 E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
                 E.&&. validQualification now usrQual
             )
-          , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
-            )
+          , ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)))
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrCompanyNameUI mPrev
           , prismAForm (singletonFilter "company-number")                             mPrev $ aopt textField (fslI MsgTableCompanyNo)
           , prismAForm (singletonFilter "is-associate")                               mPrev $ aopt textField (fslI MsgTableCompanyUser)
           -- , prismAForm (singletonFilter "is-supervisor0")                             mPrev $ aopt textField (fslI MsgTableSupervisor)
-          , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisor)
+          , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisorActive)
           , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
           , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
           , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
@@ -863,20 +867,20 @@ mkFirmUserTable isAdmin cid = do
               in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
           ]
-        dbtSorting = mconcat
-          [ single $ sortUserNameLink queryUserUser
-          , single $ sortUserEmail    queryUserUser
-          , singletonMap "postal-pref"      $ SortColumn $ queryUserUser        >>> (E.^. UserPrefersPostal)
-          , singletonMap "matriculation"    $ SortColumn $ queryUserUser        >>> (E.^. UserMatrikelnummer)
-          , singletonMap "personal-number"  $ SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber)
-          , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
-          , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
-          , singletonMap "usr-reason"       $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
-          , singletonMap "priority"         $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
+        dbtSorting = Map.fromList
+          [ sortUserNameLink queryUserUser
+          , sortUserEmail    queryUserUser
+          , ("postal-pref"      , SortColumn $ queryUserUser        >>> (E.^. UserPrefersPostal)        )
+          , ("matriculation"    , SortColumn $ queryUserUser        >>> (E.^. UserMatrikelnummer)       )
+          , ("personal-number"  , SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber))
+          , ("supervisors"      , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors        )
+          , ("reroutes"         , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute )
+          , ("usr-reason"       , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)        )
+          , ("priority"         , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)      )
           ]
-        dbtFilter = mconcat
-          [ single $ fltrUserNameEmail queryUserUser
-          , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
+        dbtFilter = Map.fromList
+          [ fltrUserNameEmail queryUserUser
+          , ("has-supervisor", FilterColumn $ \row (getLast -> criterion) ->
               let checkSuper = do
                     usrSpr <- E.from $ E.table @UserSupervisor
                     E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@@ -884,7 +888,8 @@ mkFirmUserTable isAdmin cid = do
                   Nothing     -> E.true
                   Just True   -> E.exists    checkSuper
                   Just False  -> E.notExists checkSuper
-          , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
+            )
+          , ("has-company-supervisor", FilterColumn $ \row (getLast -> criterion) ->
               let checkSuper = do
                     usrSpr <- E.from $ E.table @UserSupervisor
                     E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@@ -897,7 +902,8 @@ mkFirmUserTable isAdmin cid = do
                   Nothing     -> E.true
                   Just True   -> E.exists    checkSuper
                   Just False  -> E.notExists checkSuper
-          , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
+            )
+          , ("has-foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
               let checkSuper = do
                     usrSpr <- E.from $ E.table @UserSupervisor
                     E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@@ -910,7 +916,8 @@ mkFirmUserTable isAdmin cid = do
                   Nothing     -> E.true
                   Just True   -> E.exists    checkSuper
                   Just False  -> E.notExists checkSuper
-          , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) ->
+            )
+          , ("supervisor-is", FilterColumn $ \row (getLast -> criterion) ->
               case criterion of
                 Just uid -> do
                   -- uid <- decryptUser uuid
@@ -919,7 +926,8 @@ mkFirmUserTable isAdmin cid = do
                     E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                         E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
                 _otherwise -> E.true
-          , singletonMap "supervisors-are" $ FilterColumn $ \row criteria ->
+            )
+          , ("supervisors-are", FilterColumn $ \row criteria ->
               case criteria of
                 _ | Set.null criteria -> E.true
                   | otherwise -> do
@@ -928,7 +936,8 @@ mkFirmUserTable isAdmin cid = do
                         usrSpr <- E.from $ E.table @UserSupervisor
                         E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                             E.&&.  usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
-          , singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) ->
+            )
+          , ("is-primary-company", FilterColumn $ \row (getLast -> criterion) ->
               let checkPrimary = do
                     other <- E.from $ E.table @UserCompany
                     E.where_ $ other E.^. UserCompanyUser     E.==. queryUserUserCompany row E.^. UserCompanyUser
@@ -937,6 +946,7 @@ mkFirmUserTable isAdmin cid = do
                   Nothing     -> E.true
                   Just False  -> E.exists    checkPrimary
                   Just True   -> E.notExists checkPrimary
+            )
           ]
         -- superField = selectField $ ????
         dbtFilterUI mPrev = mconcat
@@ -1251,31 +1261,32 @@ mkFirmSuperTable isAdmin cid = do
           , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
           ]
-        dbtSorting = mconcat
-          [ single $ sortUserNameLink querySuperUser
-          , single $ sortUserEmail    querySuperUser
-          , singletonMap "matriculation"    $ SortColumn $ querySuperUser        >>> (E.^. UserMatrikelnummer)
-          , singletonMap "personal-number"  $ SortColumn $ querySuperUser        >>> (E.^. UserCompanyPersonalNumber)
-          , singletonMap "postal-pref"      $ SortColumn $ querySuperUser        >>> (E.^. UserPrefersPostal)
-          , singletonMap "supervised"       $ SortColumn $ querySuperUser        >>> firmCountForSupervisor cid Nothing
-          , singletonMap "rerouted"         $ SortColumn $ querySuperUser        >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
-          , singletonMap "user-company"     $ SortColumn (\row -> E.subSelect $ do
+        dbtSorting = Map.fromList
+          [ sortUserNameLink querySuperUser
+          , sortUserEmail    querySuperUser
+          , ("matriculation"    , SortColumn $ querySuperUser        >>> (E.^. UserMatrikelnummer))
+          , ("personal-number"  , SortColumn $ querySuperUser        >>> (E.^. UserCompanyPersonalNumber))
+          , ("postal-pref"      , SortColumn $ querySuperUser        >>> (E.^. UserPrefersPostal))
+          , ("supervised"       , SortColumn $ querySuperUser        >>> firmCountForSupervisor cid Nothing)
+          , ("rerouted"         , SortColumn $ querySuperUser        >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)))
+          , ("user-company"     , SortColumn (\row -> E.subSelect $ do
               (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
               E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId
               E.orderBy [E.asc $ cmp E.^. CompanyName]
               return (cmp E.^. CompanyName)
-            )
-          , singletonMap "def-super"      $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor)
-          , singletonMap "def-reroute"    $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute)
+            ))
+          , ("def-super"        , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor))
+          , ("def-reroute"      , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute))
           ]
-        dbtFilter = mconcat
-          [ single $ fltrUserNameEmail querySuperUser
-          , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
+        dbtFilter = Map.fromList
+          [ fltrUserNameEmail querySuperUser
+          , ("is-foreign-supervisor", FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
               case criterion of
                   Nothing     -> E.true
                   Just True   -> E.isNothing $ suc E.?. UserCompanyUser
                   Just False  -> E.isJust    $ suc E.?. UserCompanyUser
-          , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
+            )
+          , ("super-relation-foreign", FilterColumn $ \row (getLast -> criterion) ->
               let checkSuper = do
                     usrSpr <- E.from $ E.table @UserSupervisor
                     E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
@@ -1288,6 +1299,7 @@ mkFirmSuperTable isAdmin cid = do
                   Nothing     -> E.true
                   Just True   -> E.exists    checkSuper
                   Just False  -> E.notExists checkSuper
+            )
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev

src/Handler/LMS.hs

@@ -29,6 +29,7 @@ import Jobs
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.LMS
+import Handler.Utils.Company
 
 
 import qualified Data.Set as Set
@@ -50,10 +51,6 @@ import Handler.LMS.Report   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
 -- Button only needed here
 data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
@@ -302,19 +299,22 @@ instance CsvColumnsExplained LmsTableCsv where
 type LmsTableExpr = (                   E.SqlExpr (Entity QualificationUser)
                       `E.InnerJoin`     E.SqlExpr (Entity User)
                       `E.InnerJoin`     E.SqlExpr (Entity LmsUser)
-                    ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
+                      `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
+                    )
+-- due to GHC staging restrictions, we use the preprocessor instead
+#define LMS_TABLE_JOIN "IIL"
 
 queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
-queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
+queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1)
 
 queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
+queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2)
 
 queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
-queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
+queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3)
 
 queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
-queryQualBlock = $(sqlLOJproj 2 2)
+queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4)
 
 
 type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
@@ -424,11 +424,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
           let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
           pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
                   E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
-        primeComp = E.subSelect . E.from $ \uc -> do
-          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
-          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
-          return (uc E.^. UserCompanyCompany)
-    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser)
 
 
 mkLmsTable :: ( Functor h, ToSortable h
@@ -443,7 +439,7 @@ mkLmsTable :: ( Functor h, ToSortable h
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
   now <- liftIO getCurrentTime
   -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let
@@ -457,54 +453,54 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
     dbtRowKey = queryUser >>> (E.^. UserId)
     dbtProj = dbtProjId
     dbtColonnade = cols getCompanyName
-    dbtSorting = mconcat
-      [ single $ sortUserNameLink   queryUser
-      , single $ sortUserEmail      queryUser
-      , single $ sortUserMatriclenr queryUser
-      , single ("valid-until"   , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserValidUntil))
-      -- , single ("validity"      , SortColumn         $ queryQualUser  >>> validQualification nowaday)
-      , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserLastRefresh))
-      , single ("first-held"    , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserFirstHeld))
-      , single ("blocked"       , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
-      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
-      , single ("ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserIdent))
-      , single ("pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserPin))
-      -- , single ("status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
-      , single ("status"    , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
+    dbtSorting = Map.fromList
+      [ sortUserNameLink   queryUser
+      , sortUserEmail      queryUser
+      , sortUserMatriclenr queryUser
+      , ("valid-until"   , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserValidUntil))
+      -- , ("validity"      , SortColumn         $ queryQualUser  >>> validQualification nowaday)
+      , ("last-refresh"  , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserLastRefresh))
+      , ("first-held"    , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserFirstHeld))
+      , ("blocked"       , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
+      , ("schedule-renew", SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
+      , ("ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserIdent))
+      , ("pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserPin))
+      -- , ("status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
+      , ("status"    , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
                                                                               , queryLmsUser row E.^. LmsUserNotified
                                                                               ](queryLmsUser row E.^. LmsUserStarted))
 
-      , single ("started"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserStarted))
-      , single ("datepin"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserDatePin))
-      , single ("received"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserReceived))
-      , single ("notified"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
-      , single ("ended"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserEnded))
-      , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+      , ("started"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserStarted))
+      , ("datepin"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserDatePin))
+      , ("received"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserReceived))
+      , ("notified"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
+      , ("ended"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserEnded))
+      , ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
                 E.orderBy [E.asc (comp E.^. CompanyName)]
                 return (comp E.^. CompanyName)
-              )
+        )
       ]
-    dbtFilter = mconcat
-      [ single $ fltrUserNameEmail queryUser
-      , single ("ident"   , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
-      -- , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
-      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-      -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
+    dbtFilter = Map.fromList
+      [ fltrUserNameEmail queryUser
+      , ("ident"   , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
+      , ("status"  , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
+      -- , ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
+      , ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
+      -- , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
       --     if | Just renewal <- mbRenewal
       --        , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
       --                                     E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
       --        | otherwise -> E.true
       --   )
-      , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
-      , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+      , ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
+      , ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \usrAvs -> -- do
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
-      , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+      , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@@ -514,7 +510,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )
       , fltrAVSCardNos queryUser
-      , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
+      , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
         )

src/Handler/LMS/Learners.hs

@@ -76,19 +76,15 @@ instance FromNamedRecord LmsUserTableCsv where
         <*> csv Csv..: csvLmsLock
 
 instance CsvColumnsExplained LmsUserTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent      MsgCsvColumnLmsIdent
-    , single csvLmsPin        MsgCsvColumnLmsPin
-    , single csvLmsResetPin   MsgCsvColumnLmsResetPin
-    , single csvLmsDelete     MsgCsvColumnLmsDelete
-    , single csvLmsStaff      MsgCsvColumnLmsStaff
-    , single csvLmsResetTries MsgCsvColumnLmsResetTries
-    , single csvLmsLock       MsgCsvColumnLmsLock
+  csvColumnsExplanations _ = Map.fromList
+    [ (csvLmsIdent      , msg2widget MsgCsvColumnLmsIdent)
+    , (csvLmsPin        , msg2widget MsgCsvColumnLmsPin)
+    , (csvLmsResetPin   , msg2widget MsgCsvColumnLmsResetPin)
+    , (csvLmsDelete     , msg2widget MsgCsvColumnLmsDelete)
+    , (csvLmsStaff      , msg2widget MsgCsvColumnLmsStaff)
+    , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
+    , (csvLmsLock       , msg2widget MsgCsvColumnLmsLock)
     ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
 
 
 mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)

src/Handler/LMS/Report.hs

@@ -64,15 +64,12 @@ instance FromNamedRecord LmsReportTableCsv where
         <*> csv Csv..: csvLmsLock
 
 instance CsvColumnsExplained LmsReportTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent    MsgCsvColumnLmsIdent
-    , single csvLmsDate     MsgCsvColumnLmsDate
-    , single csvLmsResult   MsgCsvColumnLmsResult
-    , single csvLmsLock     MsgCsvColumnLmsLock
+  csvColumnsExplanations _ = Map.fromList
+    [ (csvLmsIdent  , msg2widget MsgCsvColumnLmsIdent)
+    , (csvLmsDate   , msg2widget MsgCsvColumnLmsDate)
+    , (csvLmsResult , msg2widget MsgCsvColumnLmsResult)
+    , (csvLmsLock   , msg2widget MsgCsvColumnLmsLock)
     ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
 
 data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
   deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)

src/Handler/LMS/Users.hs

@@ -68,23 +68,19 @@ instance FromNamedRecord LmsUserTableCsv where
         <*> csv Csv..: csvLmsStaff
 
 instance CsvColumnsExplained LmsUserTableCsv where
-  csvColumnsExplanations _ = mconcat
-    [ single csvLmsIdent    MsgCsvColumnLmsIdent
-    , single csvLmsPin      MsgCsvColumnLmsPin
-    , single csvLmsResetPin MsgCsvColumnLmsResetPin
-    , single csvLmsDelete   MsgCsvColumnLmsDelete
-    , single csvLmsStaff    MsgCsvColumnLmsStaff
+  csvColumnsExplanations _ = Map.fromList
+    [ (csvLmsIdent    , msg2widget MsgCsvColumnLmsIdent)
+    , (csvLmsPin      , msg2widget MsgCsvColumnLmsPin)
+    , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
+    , (csvLmsDelete   , msg2widget MsgCsvColumnLmsDelete)
+    , (csvLmsStaff    , msg2widget MsgCsvColumnLmsStaff)
     ]
-    where
-      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
-      single k v = singletonMap k [whamlet|_{v}|]
-
 
 
 mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
 mkUserTable _sid qsh qid = do
   cutoff <- liftHandler $ lmsDeletionDate Nothing
-  dbtCsvName <- csvFilenameLmsUser qsh  
+  dbtCsvName <- csvFilenameLmsUser qsh
   let dbtCsvSheetName = dbtCsvName
   let
     userDBTable = DBTable{..}
@@ -160,7 +156,7 @@ getLmsUsersDirectR sid qsh = do
     selectList [ LmsUserQualification ==. qid
                , LmsUserEnded ==. Nothing
                -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
-               ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+               ] [Asc LmsUserStarted, Asc LmsUserIdent]
 
     {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
       Ex.select $ do
@@ -175,7 +171,7 @@ getLmsUsersDirectR sid qsh = do
           , csvLUTstaff    = LmsBool False
           }
       -}
-  LmsConf{..} <- getsYesod $ view _appLmsConf  
+  LmsConf{..} <- getsYesod $ view _appLmsConf
   let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
       --csvRenderedHeader = lmsUserTableCsvHeader
       --cvsRendered = CsvRendered {..}
@@ -188,10 +184,10 @@ getLmsUsersDirectR sid qsh = do
       csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh
   let nr  = length lms_users
-      msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
+      msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
   $logInfoS "LMS" msg
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
 
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/MailCenter.hs

@@ -41,12 +41,6 @@ import qualified Data.ByteString.Lazy as LB
 import Handler.Utils
 
 
-
--- 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)
 
@@ -101,15 +95,15 @@ mkMCTable = do
       -- , sortable Nothing (i18nCell MsgCommContent)    $ \(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)
+    dbtSorting = Map.fromList
+      [ ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
+      , ("recipient" , sortUserNameBareM queryRecipient)
       ]
-    dbtFilter = mconcat
-      [ single ("sent"      , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
-      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
-      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
-      -- , single ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+    dbtFilter = Map.fromList
+      [ ("sent"      , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
+      , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
+      , ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      -- , ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
       ]
     dbtFilterUI mPrev = mconcat
       [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)

src/Handler/PrintCenter.hs

@@ -39,11 +39,6 @@ import qualified Data.CaseInsensitive as CI
 import Jobs.Queue
 
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
-
 data LRQF = LRQF
     { lrqfLetter    :: Text
     , lrqfUser      :: Either UserEmail UserId
@@ -224,33 +219,33 @@ mkPJTable = do
       , sortable (Just "qualification")(i18nCell MsgPrintQualification)    $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
       , sortable (Just "lmsid")        (i18nCell MsgPrintLmsUser)          $ \(   view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
       ]
-    dbtSorting = mconcat
-      [ single ("name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
-      , single ("filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
-      , single ("created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
-      , single ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
-      , single ("apcid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobApcIdent))
-      , single ("recipient"    , sortUserNameBareM queryRecipient)
-      , single ("affected"     , sortUserNameBareM queryAffected)
-      , single ("sender"       , sortUserNameBareM querySender   )
-      , single ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
-      , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
-      , single ("lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
+    dbtSorting = Map.fromList
+      [ ("name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
+      , ("filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
+      , ("created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
+      , ("acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
+      , ("apcid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobApcIdent))
+      , ("recipient"    , sortUserNameBareM queryRecipient)
+      , ("affected"     , sortUserNameBareM queryAffected )
+      , ("sender"       , sortUserNameBareM querySender   )
+      , ("course"       , SortColumn $ queryCourse        >>> (E.?. CourseName))
+      , ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
+      , ("lmsid"        , SortColumn $ queryPrintJob      >>> (E.^. PrintJobLmsUser))
       ]
-    dbtFilter = mconcat
-      [ single ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
-      , single ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
-      , single ("filename"     , FilterColumn . E.mkContainsFilter                                $ views (to queryPrintJob)      (E.^. PrintJobFilename))
-      , single ("created"      , FilterColumn . E.mkDayFilter                                     $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      --, single ("created"      , FilterColumn . E.mkDayBetweenFilter                            $ views (to queryPrintJob)      (E.^. PrintJobCreated))
-      , single ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
-      , single ("affected"     , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryAffected)      (E.?. UserDisplayName))
-      , single ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
-      , single ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
-      , single ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
-      , single ("lmsid"        , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
+    dbtFilter = Map.fromList
+      [ ("name"         , FilterColumn . E.mkContainsFilterWithCommaPlus id                $ views (to queryPrintJob)      (E.^. PrintJobName))
+      , ("apcid"        , FilterColumn . E.mkContainsFilterWithComma     id                $ views (to queryPrintJob)      (E.^. PrintJobApcIdent))
+      , ("filename"     , FilterColumn . E.mkContainsFilter                                $ views (to queryPrintJob)      (E.^. PrintJobFilename))
+      , ("created"      , FilterColumn . E.mkDayFilter                                     $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      --, ("created"      , FilterColumn . E.mkDayBetweenFilter                            $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      , ("recipient"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryRecipient)     (E.?. UserDisplayName))
+      , ("affected"     , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to queryAffected)      (E.?. UserDisplayName))
+      , ("sender"       , FilterColumn . E.mkContainsFilterWithCommaPlus Just              $ views (to querySender)        (E.?. UserDisplayName))
+      , ("course"       , FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryCourse)        (E.?. CourseName))
+      , ("qualification", FilterColumn . E.mkContainsFilterWith          (Just . CI.mk)    $ views (to queryQualification) (E.?. QualificationName))
+      , ("lmsid"        , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob)      (E.^. PrintJobLmsUser))
 
-      , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
+      , ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
       ]
     dbtFilterUI mPrev = mconcat
       [ prismAForm (singletonFilter "name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus)
@@ -524,23 +519,25 @@ getPrintLogR = do
 
         dbtIdent = "lpr-log" :: Text
         dbtSQLQuery l = do
-          E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
-            -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
+          E.where_ $ (l E.^. TransactionLogInfo E.->>. "interface-name") `E.in_` E.valList ["LPR", "LETTER","APC", "Printer"]
+          -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
           return l
         dbtRowKey = (E.^. TransactionLogId)
         dbtProj = dbtProjSimple $ \(Entity _ l) -> do
           return (l, Aeson.fromJSON $ transactionLogInfo l)
         dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just "time")    (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
-          , sortable (Just "status")  (textCell "Status")                $ tCell    (cellMaybe iconBoolCell . transactionInterfaceSuccess)
-          , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype)     $ tCell    (              textCell . transactionInterfaceSubtype)
-          , sortable (Just "info")    (i18nCell MsgSystemMessageContent) $ tCellErr (              textCell . transactionInterfaceInfo)
+          [ sortable (Just "time")      (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
+          , sortable (Just "status")    (textCell "Status"                 ) $ tCell    (cellMaybe iconBoolCell . transactionInterfaceSuccess)
+          , sortable (Just "interface") (i18nCell MsgInterfaceName         ) $ tCell    (              textCell . transactionInterfaceName)
+          , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype      ) $ tCell    (              textCell . transactionInterfaceSubtype)
+          , sortable (Just "info")      (i18nCell MsgSystemMessageContent  ) $ tCellErr (              textCell . transactionInterfaceInfo)
           ]
         dbtSorting = mconcat
-          [ singletonMap "time"     $ SortColumn (E.^. TransactionLogTime)
-          , singletonMap "status"   $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
-          , singletonMap "subtype"  $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
-          , singletonMap "info"     $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info"   )
+          [ singletonMap "time"      $ SortColumn (E.^. TransactionLogTime)
+          , singletonMap "status"    $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-success")
+          , singletonMap "interface" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-name"   )
+          , singletonMap "subtype"   $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-subtype")
+          , singletonMap "info"      $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-info"   )
           ]
         dbtFilter   = mempty
         dbtFilterUI = mempty

src/Handler/Qualification.hs

@@ -18,6 +18,7 @@ import Jobs
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.LMS
+import Handler.Utils.Company
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -36,10 +37,6 @@ import Database.Esqueleto.Utils.TH
 
 -- import Handler.Utils.Qualification (validQualification)
 
--- avoids repetition of local definitions
-single :: (k,a) -> Map k a
-single = uncurry Map.singleton
-
 
 getQualificationSchoolR :: SchoolId -> Handler Html
 getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
@@ -349,11 +346,7 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo
     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
     E.where_ $    fltr qualUser
             E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-    let primeComp = E.subSelect . E.from $ \uc -> do
-          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
-          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
-          return (uc E.^. UserCompanyCompany)
-    return (qualUser, user, lmsUser, qualBlock, primeComp)
+    return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user)
 
 
 mkQualificationTable ::
@@ -370,7 +363,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
   now <- liftIO getCurrentTime
   -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let
@@ -386,40 +379,40 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
     dbtRowKey = queryUser >>> (E.^. UserId)
     dbtProj = dbtProjId
     dbtColonnade = cols getCompanyName
-    dbtSorting = mconcat
-      [ single $ sortUserNameLink   queryUser
-      , single $ sortUserEmail      queryUser
-      , single $ sortUserMatriclenr queryUser
-      , single ("first-held"    , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
-      , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
-      , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
-      , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-      , single ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
-      , single ("lms-status-plus",SortColumnNullsInv  $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
+    dbtSorting = Map.fromList
+      [ sortUserNameLink   queryUser
+      , sortUserEmail      queryUser
+      , sortUserMatriclenr queryUser
+      , ("first-held"    , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
+      , ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
+      , ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
+      , ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
+      , ("lms-status-plus",SortColumnNullsInv  $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
                                                                            , E.joinV (queryLmsUser row E.?. LmsUserNotified)
                                                                            ,          queryLmsUser row E.?. LmsUserStarted])
-      , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
-      , single ("user-company"  , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+      , ("schedule-renew", SortColumnNullsInv  $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
+      , ("user-company"  , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
                 E.orderBy [E.asc (comp E.^. CompanyName)]
                 return (comp E.^. CompanyName)
-              )
-      -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
+        )
+      -- , ("validity", SortColumn $ queryQualUser >>> validQualification now)
       ]
-    dbtFilter = mconcat
-      [ single $ fltrUserNameEmail queryUser
-      , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+    dbtFilter = Map.fromList
+      [ fltrUserNameEmail queryUser
+      , ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \usrAvs -> -- do
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
       , fltrAVSCardNos queryUser
-      , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
+      , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
         )
-      , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+      , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
               E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@@ -428,18 +421,18 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )
-      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-      , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
+      , ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
+      , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
           if | Just renewal <- mbRenewal
              , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
                                           E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
              | otherwise -> E.true
         )
-      , single ("tobe-notified", FilterColumn $ \row criterion ->
+      , ("tobe-notified", FilterColumn $ \row criterion ->
           if  | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
               | otherwise -> E.true
         )
-      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
+      , ("status"  , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
       ]
     dbtFilterUI mPrev = mconcat
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev

src/Handler/School/DayTasks.hs

@@ -0,0 +1,403 @@
+
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only
+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only
+
+module Handler.School.DayTasks
+  ( getSchoolDayR, postSchoolDayR
+  ) where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Company
+import Handler.Utils.Occurrences
+
+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.Experimental as E
+import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
+import qualified Database.Esqueleto.Utils as E
+import           Database.Esqueleto.PostgreSQL.JSON ((@>.))
+import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
+import Database.Esqueleto.Utils.TH
+
+
+
+data DailyTableAction = DailyActDummy -- 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 DailyTableAction
+instance Finite DailyTableAction
+nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''DailyTableAction id
+
+data DailyTableActionData = DailyActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+-- | partial JSON object to be used for filtering with "@>"
+--   ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
+occurrenceDayValue :: Day -> Value
+occurrenceDayValue d = Aeson.object
+  [ "exceptions" Aeson..=
+    [ Aeson.object
+      [ "exception" Aeson..= ("occur"::Text)
+      , "day"       Aeson..= d
+  ] ] ]
+
+{- More efficient DB-only version, but ignores regular schedules
+getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
+getDayTutorials ssh d = E.unValue <<$>> E.select (do
+    (trm :& crs :& tut) <- E.from $ E.table @Term
+      `E.innerJoin` E.table @Course   `E.on` (\(trm :& crs)      -> crs E.^. CourseTerm E.==. trm E.^. TermId)
+      `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId   E.==. tut E.^. TutorialCourse)
+    E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd)
+        E.&&.  crs E.^. CourseSchool E.==. E.val ssh
+        E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d))
+    return $ tut E.^. TutorialId
+  )
+-}
+
+-- Datatype to be used for memcaching occurrences
+data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
+  deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (Hashable, Binary)
+
+getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
+getDayTutorials ssh dlimit@(dstart, dend )
+  | dstart > dend = return mempty
+  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do
+    candidates <- E.select $ do
+      (trm :& crs :& tut) <- E.from $ E.table @Term
+          `E.innerJoin` E.table @Course   `E.on` (\(trm :& crs)      -> crs E.^. CourseTerm E.==. trm E.^. TermId)
+          `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId   E.==. tut E.^. TutorialCourse)
+      E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
+          E.&&.  trm E.^. TermStart    E.<=. E.val dend
+          E.&&.  trm E.^. TermEnd      E.>=. E.val dstart
+      return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
+    -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
+    return $ mapMaybe checkCandidate candidates
+  where
+    period = Set.fromAscList [dstart..dend]
+
+    checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case
+    checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _)
+      | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ
+        = Just tutId
+      | otherwise
+        = Nothing
+
+-- Datatype to be used for memcaching occurrences
+data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day)
+  deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (Hashable, Binary)
+
+
+-- | like getDayTutorials, but also returns the lessons occurring within the given time frame
+getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime])
+getDayTutorials' ssh dlimit@(dstart, dend )
+  | dstart > dend = return mempty
+  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials ssh dlimit) $ do
+    candidates <- E.select $ do
+      (trm :& crs :& tut) <- E.from $ E.table @Term
+          `E.innerJoin` E.table @Course   `E.on` (\(trm :& crs)      -> crs E.^. CourseTerm E.==. trm E.^. TermId)
+          `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId   E.==. tut E.^. TutorialCourse)
+      E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
+          E.&&.  trm E.^. TermStart    E.<=. E.val dend
+          E.&&.  trm E.^. TermEnd      E.>=. E.val dstart
+      return (trm, tut)
+    -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
+    return $ foldMap checkCandidate candidates
+  where
+    checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime]
+    checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}})
+      | let lessons = Set.filter lessonFltr $ occurringLessons trm occ
+      , notNull lessons
+        = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway
+      | otherwise
+        = mempty
+
+    lessonFltr :: LessonTime -> Bool
+    lessonFltr LessonTime{..} = dstart <= localDay lessonStart
+                            &&  dend   >= localDay lessonEnd
+
+
+type DailyTableExpr =
+  (                     E.SqlExpr (Entity Course)
+    `E.InnerJoin`       E.SqlExpr (Entity Tutorial)
+    `E.InnerJoin`       E.SqlExpr (Entity TutorialParticipant)
+    `E.InnerJoin`       E.SqlExpr (Entity User)
+    `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity UserAvs))
+    `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity UserDay))
+    `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity TutorialParticipantDay))
+  )
+
+type DailyTableOutput = E.SqlQuery
+  ( E.SqlExpr (Entity Course)
+  , E.SqlExpr (Entity Tutorial)
+  , E.SqlExpr (Entity TutorialParticipant)
+  , E.SqlExpr (Entity User)
+  , E.SqlExpr (Maybe (Entity UserAvs))
+  , E.SqlExpr (Maybe (Entity UserDay))
+  , E.SqlExpr (Maybe (Entity TutorialParticipantDay))
+  , E.SqlExpr (E.Value (Maybe CompanyId))
+  , E.SqlExpr (E.Value (Maybe [QualificationId]))
+  )
+type DailyTableData   = DBRow
+  ( Entity Course
+  , Entity Tutorial
+  , Entity TutorialParticipant
+  , Entity User
+  , Maybe (Entity UserAvs)
+  , Maybe (Entity UserDay)
+  , Maybe (Entity TutorialParticipantDay)
+  , E.Value (Maybe CompanyId)
+  , E.Value (Maybe [QualificationId])
+  )
+
+-- force declarations before this point to avoid staging restrictions
+$(return [])
+
+
+queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
+queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
+
+queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
+queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
+
+queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
+queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now
+-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
+
+queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(sqlMIXproj' ''DailyTableExpr 4)
+
+queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
+queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5)
+
+queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay))
+queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6)
+
+queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay))
+queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7)
+
+resultCourse :: Lens' DailyTableData (Entity Course)
+resultCourse = _dbrOutput . _1
+
+resultTutorial :: Lens' DailyTableData (Entity Tutorial)
+resultTutorial = _dbrOutput . _2
+
+resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
+resultParticipant = _dbrOutput . _3
+
+resultUser :: Lens' DailyTableData (Entity User)
+resultUser = _dbrOutput . _4
+
+resultUserAvs :: Traversal' DailyTableData UserAvs
+resultUserAvs = _dbrOutput . _5 . _Just . _entityVal
+
+resultUserDay :: Traversal' DailyTableData UserDay
+resultUserDay = _dbrOutput . _6 . _Just . _entityVal
+
+resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay
+resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal
+
+resultCompanyId :: Traversal' DailyTableData CompanyId
+resultCompanyId = _dbrOutput . _8 . _unValue . _Just
+
+resultCourseQualis :: Traversal' DailyTableData [QualificationId]
+resultCourseQualis = _dbrOutput . _9 . _unValue . _Just
+
+
+instance HasEntity DailyTableData User where
+  hasEntity = resultUser
+
+instance HasUser DailyTableData where
+  hasUser = resultUser . _entityVal
+
+-- see colRatedField' for an example of formCell usage
+
+drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit
+drivingPermitField = selectField' Nothing optionsFinite
+
+-- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam
+-- eyeExamField = selectField optionsFinite
+
+-- This does not type:
+-- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+-- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+--   (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+--   (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
+--     over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x
+--   )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+
+-- colEyeExamField :: TODO
+
+colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
+    over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+      mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note)
+  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+
+colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
+    over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
+  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+
+colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
+    over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+      mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note)
+  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+
+colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
+    over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
+  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+
+mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
+mkDailyTable isAdmin ssh nd = do
+  tutLessons <- getDayTutorials' ssh (nd,nd)
+  dday <- formatTime SelFormatDate nd
+  let
+    tutIds = Map.keys tutLessons
+    dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
+    dbtSQLQuery  (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
+      EL.on $ tut E.^. TutorialId     E.=?. tdy E.?. TutorialParticipantDayTutorial
+        E.&&. usr E.^. UserId         E.=?. tdy E.?. TutorialParticipantDayUser
+        E.&&. E.val nd                E.=?. tdy E.?. TutorialParticipantDayDay
+      EL.on $ usr E.^. UserId         E.=?. udy E.?. UserDayUser
+        E.&&. E.val nd                E.=?. udy E.?. UserDayDay
+      EL.on $ usr E.^. UserId         E.=?. avs E.?. UserAvsUser
+      EL.on $ usr E.^. UserId         E.==. tpu E.^. TutorialParticipantUser
+      EL.on $ tut E.^. TutorialId     E.==. tpu E.^. TutorialParticipantTutorial
+      EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
+      E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
+      let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
+            E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
+            let cqQual  = cq E.^. CourseQualificationQualification
+                cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
+            return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
+      return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
+    dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
+    dbtProj   = dbtProjId
+    dbtColonnade = mconcat
+      [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
+        sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
+      , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \row ->
+          let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
+                      = row ^. resultCourse   . _entityVal
+              tutName = row ^. resultTutorial . _entityVal . _tutorialName
+          in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
+      , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
+      , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
+          -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
+          cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
+      -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
+      , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
+      , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
+      , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
+      , colUserNameModalHdr MsgCourseParticipant ForProfileDataR
+      , colUserMatriclenr isAdmin
+      , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
+      , sortable (Just "permit")        (i18nCell   MsgTutorialDrivingPermit)      $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
+      , sortable (Just "eye-exam")      (i18nCell   MsgTutorialEyeExam)            $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam       -> x) -> x & cellMaybe i18nCell
+      , sortable (Just "note-tutorial") (i18nCell   MsgTutorialNote)               $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote          -> x) -> x & cellMaybe textCell
+      , sortable (Just "attendance")    (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance        -> x) -> x & cellMaybe tickmarkCell
+      , sortable (Just "note-attend")   (i18nCell $ MsgTutorialDayNote       dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just      -> x) -> x & cellMaybe textCell
+      , sortable (Just "parking")       (i18nCell   MsgTableUserParkingToken)      $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
+      -- , colParkingField id
+      ]
+    dbtSorting = Map.fromList
+      [ sortUserNameLink queryUser
+      , sortUserMatriclenr  queryUser
+      , ("course"         , SortColumn $ queryCourse      >>> (E.^. CourseName))
+      , ("tutorial"       , SortColumn $ queryTutorial    >>> (E.^. TutorialName))
+      , ("user-company"   , SortColumn $ queryUser        >>> selectCompanyUserPrime)
+      , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
+      , ("card-no"        , SortColumn $ queryUserAvs     >>> (E.?. UserAvsLastCardNo))
+      , ("permit"         , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
+      , ("eye-exam"       , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
+      , ("note-tutorial"  , SortColumn         $ queryParticipant >>> (E.^. TutorialParticipantNote))
+      , ("attendance"     , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
+      , ("note-attend"    , SortColumn         $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
+      , ("parking"        , SortColumnNullsInv $ queryUserDay     >>> (E.?. UserDayParkingToken))
+      ]
+    dbtFilter = Map.fromList
+      [ fltrUserNameEmail   queryUser
+      , fltrUserMatriclenr  queryUser
+      , ("course"       , FilterColumn . E.mkContainsFilter $ queryCourse   >>> (E.^. CourseName))
+      , ("tutorial"     , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
+      , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser     >>> selectCompanyUserPrime)
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "course"       . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgFilterCourse)
+      , prismAForm (singletonFilter "tutorial"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCourseTutorial)
+      , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgTablePrimeCompany)
+      , fltrUserNameEmailUI  mPrev
+      , fltrUserMatriclenrUI mPrev
+      ]
+    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
+    dbtIdent :: Text
+    dbtIdent = "daily"
+    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 DailyTableActionData, DBFormResult TutorialId Bool DailyTableData)
+                -> FormResult (      DailyTableActionData,          Set TutorialId)
+    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 [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+
+getSchoolDayR,  postSchoolDayR :: SchoolId -> Day -> Handler Html
+getSchoolDayR = postSchoolDayR
+postSchoolDayR ssh nd = do
+  isAdmin <- hasReadAccessTo AdminR
+  dday <- formatTime SelFormatDate nd
+  (_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
+  siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
+    setTitleI (MsgMenuSchoolDay ssh dday)
+    [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
+      ^{tableDaily}
+    |]

src/Handler/Sheet/Download.hs

@@ -66,7 +66,7 @@ getSArchiveR tid ssh csh shn = do
       | otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) <//>)
   sftDirectories <- if
     | not multipleSFTs -> return mempty
-    | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do
+    | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectOne . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do
         E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet
          E.&&. sFile E.?. SheetFileType  E.==. psFile E.?. PersonalisedSheetFileType
          E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle
@@ -78,7 +78,7 @@ getSArchiveR tid ssh csh shn = do
           [ sFile E.?. SheetFileModified
           , psFile E.?. PersonalisedSheetFileModified
           ]
-  
+
   serveZipArchive archiveName $ do
     forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile
       { sheetFileType = sft

src/Handler/Sheet/Show.hs

@@ -128,7 +128,7 @@ getSShowR tid ssh csh shn = do
     [ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR
     , wouldHaveReadAccessToIff  [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR
     ]
-  mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do
+  mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectOne . E.from $ \(exam `E.InnerJoin` course) -> do
     E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
     E.where_ $ exam E.^. ExamId E.==. E.val eId
     return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName)

src/Handler/Term.hs

@@ -29,7 +29,7 @@ import qualified Control.Monad.State.Class as State
 validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
              => FormValidator TermForm m ()
 validateTerm = do
-  TermForm{..} <- State.get  
+  TermForm{..} <- State.get
   guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
   guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
   guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
@@ -87,7 +87,7 @@ getTermShowR = do
                                     $of Left singleHoliday
                                       ^{formatTimeW SelFormatDate singleHoliday}
                                     $of Right (startD, endD)
-                                      ^{formatTimeRangeW SelFormatDate startD (Just endD)}                                       
+                                      ^{formatTimeRangeW SelFormatDate startD (Just endD)}
                           |]
                   ]
                 dbtSorting = Map.fromList
@@ -150,11 +150,11 @@ postTermEditR = do
                       Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd]
              in mempty
                   { tftName         = Just ntid
-                  , tftStart        = Just tStart 
-                  , tftEnd          = Just tEnd  
+                  , tftStart        = Just tStart
+                  , tftEnd          = Just tEnd
                   , tftLectureStart = Just tLecStart
                   , tftLectureEnd   = Just tLecEnd
-                  , tftHolidays     = Just tHolys 
+                  , tftHolidays     = Just tHolys
                   }
   termEditHandler Nothing template
 
@@ -201,6 +201,7 @@ termEditHandler mtid template = do
                 , termActiveFor = tafFor
                 }
             lift . audit $ TransactionTermEdit tid
+          memcachedFlushClass MemcachedKeyClassTutorialOccurrences
           addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       FormMissing      -> return ()
@@ -332,7 +333,7 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do
             (fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing
             (toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing
             (forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for") & addPlaceholder (mr MsgTermActiveForPlaceholder)) Nothing
-            
+
             let res = TermActiveForm <$> fromRes <*> toRes <*> forRes
                 res' = res <&> \newDat oldDat -> if
                   | newDat `elem` oldDat

src/Handler/Tutorial/Edit.hs

@@ -25,21 +25,20 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -
 getTEditR = postTEditR
 postTEditR tid ssh csh tutn = do
   (cid, tutid, template) <- runDB $ do
-    (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn        
+    (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
     tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
       E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
       return $ tutor E.^. TutorUser
 
     tutorInvites <- sourceInvitationsF @Tutor tutid
 
-    let      
+    let
       template = TutorialForm
         { tfName            = tutorialName
         , tfType            = tutorialType
         , tfCapacity        = tutorialCapacity
-        , tfRoom            = tutorialRoom
         , tfRoomHidden      = tutorialRoomHidden
-        , tfTime            = tutorialTime
+        , tfTime            = tutorialTime & unJSONB
         , tfRegGroup        = tutorialRegGroup
         , tfRegisterFrom    = tutorialRegisterFrom
         , tfRegisterTo      = tutorialRegisterTo
@@ -62,9 +61,8 @@ postTEditR tid ssh csh tutn = do
         , tutorialCourse          = cid
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
-        , tutorialRoom            = tfRoom
         , tutorialRoomHidden      = tfRoomHidden
-        , tutorialTime            = tfTime
+        , tutorialTime            = tfTime & JSONB
         , tutorialRegGroup        = tfRegGroup
         , tutorialRegisterFrom    = tfRegisterFrom
         , tutorialRegisterTo      = tfRegisterTo
@@ -88,6 +86,7 @@ postTEditR tid ssh csh tutn = do
     case insertRes of
       Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
       Nothing -> do
+        memcachedFlushClass MemcachedKeyClassTutorialOccurrences
         addMessageI Success $ MsgTutorialEdited tfName
         redirect $ CourseR tid ssh csh CTutorialListR
 

src/Handler/Tutorial/Form.hs

@@ -25,7 +25,6 @@ data TutorialForm = TutorialForm
   , tfRegGroup        :: Maybe (CI Text)
   , tfTutorControlled :: Bool
   , tfCapacity        :: Maybe Int
-  , tfRoom            :: Maybe RoomReference
   , tfRoomHidden      :: Bool
   , tfTime            :: Occurrences
   , tfRegisterFrom    :: Maybe UTCTime
@@ -75,7 +74,6 @@ tutorialForm cid template html = do
     <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
     <*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template)
     <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
-    <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (tfRoom <$> template)
     <*> apopt checkBoxField (fslI MsgTableTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False)
     <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
     <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgTutorialDate)

src/Handler/Tutorial/List.hs

@@ -29,18 +29,18 @@ getCTutorialListR tid ssh csh = do
     tutorialDBTable = DBTable{..}
       where
         resultTutorial :: Lens' (DBRow (Entity Tutorial, Int, Bool)) (Entity Tutorial)
-        resultTutorial = _dbrOutput . _1
+        resultTutorial     = _dbrOutput . _1
         resultParticipants = _dbrOutput . _2
-        resultShowRoom = _dbrOutput . _3
-        
+        resultHideRoom     = _dbrOutput . _3
+
         dbtSQLQuery tutorial = do
           E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
           let participants :: E.SqlExpr (E.Value Int)
               participants = E.subSelectCount . E.from $ \tutorialParticipant ->
                 E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
-          let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) muid
-                   E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
-          return (tutorial, participants, showRoom)
+          let hideRoom = maybe E.true (E.not__ . flip showTutorialRoom tutorial . E.val) muid
+                   E.&&. (tutorial E.^. TutorialRoomHidden)
+          return (tutorial, participants, hideRoom)
         dbtRowKey = (E.^. TutorialId)
         dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId
         dbtColonnade = dbColonnade $ mconcat
@@ -61,10 +61,10 @@ getCTutorialListR tid ssh csh = do
                      |]
           , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
           , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity
-          , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if
-              | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
-              | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
-          , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
+          , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res ->
+              let roomHidden = res ^. resultHideRoom
+                  ttime      = res ^. resultTutorial . _entityVal . _tutorialTime
+              in occurrencesCell roomHidden ttime
           , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup
           , sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
           , sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
@@ -89,7 +89,6 @@ getCTutorialListR tid ssh csh = do
                                                         in participantCount
             )
           , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
-          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
           , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
           , ("register-from"    , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
           , ("register-to"      , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterTo )

src/Handler/Tutorial/New.hs

@@ -25,7 +25,7 @@ postCTutorialNewR tid ssh csh = do
   ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
 
   formResult newTutResult $ \TutorialForm{..} -> do
-    insertRes <- runDBJobs $ do      
+    insertRes <- runDBJobs $ do
       now <- liftIO getCurrentTime
       term <- get404 $ course ^. _courseTerm
       insertRes <- insertUnique Tutorial
@@ -33,9 +33,8 @@ postCTutorialNewR tid ssh csh = do
         , tutorialCourse          = cid
         , tutorialType            = tfType
         , tutorialCapacity        = tfCapacity
-        , tutorialRoom            = tfRoom
         , tutorialRoomHidden      = tfRoomHidden
-        , tutorialTime            = tfTime
+        , tutorialTime            = JSONB tfTime
         , tutorialRegGroup        = tfRegGroup
         , tutorialRegisterFrom    = tfRegisterFrom
         , tutorialRegisterTo      = tfRegisterTo

src/Handler/Tutorial/Register.hs

@@ -9,6 +9,7 @@ module Handler.Tutorial.Register
 import Import
 import Handler.Utils
 import Handler.Utils.Tutorial
+import Handler.Utils.Company
 
 
 postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
@@ -21,8 +22,12 @@ postTRegisterR tid ssh csh tutn = do
 
   formResult btnResult $ \case
     BtnRegister -> do
-      runDB . void . insert $ TutorialParticipant tutid uid
-      addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
+      ok <- runDB $ do
+        fsh <- selectCompanyUserPrime' uid
+        insertUnique $ TutorialParticipant tutid uid fsh Nothing Nothing Nothing
+      if isJust ok
+        then addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
+        else addMessageI Error   $ MsgTutorialRegisteredFail    tutorialName   -- cannot happen, but it is nonetheless better to be safe than crashing
       redirect $ CourseR tid ssh csh CShowR
     BtnDeregister -> do
       runDB . deleteBy $ UniqueTutorialParticipant tutid uid

src/Handler/Utils.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,7 +26,7 @@ import Handler.Utils.I18n       as Handler.Utils
 import Handler.Utils.Widgets    as Handler.Utils
 import Handler.Utils.Database   as Handler.Utils
 import Handler.Utils.Occurrences as Handler.Utils
-import Handler.Utils.Memcached  as Handler.Utils hiding (manageMemcachedLocalInvalidations)
+import Handler.Utils.Memcached  as Handler.Utils
 import Handler.Utils.Files      as Handler.Utils
 import Handler.Utils.Download   as Handler.Utils
 import Handler.Utils.AuthorshipStatement as Handler.Utils

src/Handler/Utils/AuthorshipStatement.hs

@@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map
 import Handler.Utils.Form (i18nLangMap, I18nLang(..))
 
 import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.ByteArray as BA
@@ -81,7 +81,7 @@ getSheetAuthorshipStatement :: MonadIO m
                             => Entity Sheet
                             -> SqlReadT m (Maybe (Entity AuthorshipStatementDefinition))
 getSheetAuthorshipStatement (Entity _ Sheet{..}) = withCompatibleBackend @SqlBackend $ traverse getJustEntity <=< runMaybeT $ do
-  Entity _ School{..} <- MaybeT . E.selectMaybe . E.from $ \(school `E.InnerJoin` course) -> do
+  Entity _ School{..} <- MaybeT . E.selectOne . E.from $ \(school `E.InnerJoin` course) -> do
     E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
     E.where_ $ course E.^. CourseId E.==. E.val sheetCourse
     return school

src/Handler/Utils/Avs.hs

@@ -222,7 +222,7 @@ avsQueryNoCacheDefault qry = do
     qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
     throwLeftM $ qfun qry
 
-avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
+avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q)
                   ,   MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
 avsQueryCached qry =
   getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case

src/Handler/Utils/Company.hs

@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.Utils.Company where
 
 
@@ -21,6 +23,9 @@ import qualified Database.Esqueleto.PostgreSQL   as E
 import Handler.Utils.Users
 import Handler.Utils.Widgets
 
+-- KeyCompany is CompanyShorthand, i.e. CI Text
+instance E.SqlString (Key Company)
+
 -- Snippet to restrict to primary company only
 --  E.&&. E.notExists (do
 --      othr <- E.from $ E.table @UserCompany
@@ -233,7 +238,8 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
       $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
       $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
 
--- | retrieve maximum company user priority fo a user
+-- | retrieve maximum company user priority for a user
+
 getCompanyUserMaxPrio :: UserId -> DB Int
 getCompanyUserMaxPrio uid = do
   mbMaxPrio <- E.selectOne $ do
@@ -241,3 +247,23 @@ getCompanyUserMaxPrio uid = do
     E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
     return . E.max_ $ usrCmp E.^. UserCompanyPriority
   return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
+
+-- | retrieve maximum company user priority for a user within SQL query
+--   Note: if there a multiple top-companies, only one is returned
+selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId))
+selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId
+
+-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)`
+selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
+                        => UserId -> ReaderT backend m (Maybe CompanyId)
+selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid
+
+-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId)
+-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany]
+
+selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId))
+selectCompanyUserPrimeHelper uid = do
+  uc <- E.from $ E.table @UserCompany
+  E.where_ $ uc E.^. UserCompanyUser E.==. uid
+  E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+  return (uc E.^. UserCompanyCompany)

src/Handler/Utils/Delete.hs

@@ -21,6 +21,7 @@ module Handler.Utils.Delete
 
 import Import
 import Handler.Utils.Form
+import Handler.Utils.Memcached
 
 import qualified Data.Text as Text
 import qualified Data.Set as Set
@@ -113,6 +114,7 @@ deleteR' DeleteRoute{..} = do
     True -> do
       runDBJobs $ do
         forM_ drRecords $ \k -> drDelete k $ delete k
+        memcachedFlushClass MemcachedKeyClassTutorialOccurrences
         addMessageI Success drSuccessMessage
       redirect drSuccess
     False ->

src/Handler/Utils/Files.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -18,8 +18,6 @@ import Foundation.Type
 import Foundation.DB
 import Utils.Metrics
 
-import Data.Monoid (First(..))
-
 import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit.List as C (unfoldM)
 
@@ -32,7 +30,7 @@ import qualified Database.Esqueleto.Utils as E
 import System.FilePath (normalise, makeValid)
 import Data.List (dropWhileEnd)
 
-import qualified Data.ByteString as ByteString
+{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-}
 
 
 data SourceFilesException
@@ -44,60 +42,19 @@ data SourceFilesException
 makePrisms ''SourceFilesException
 
 
-fileChunkARC :: ( MonadHandler m
-                , HandlerSite m ~ UniWorX
-                )
-             => Maybe Int
-             -> (FileContentChunkReference, (Int, Int))
-             -> m (Maybe (ByteString, Maybe FileChunkStorage))
+fileChunk :: ( MonadHandler m )
+             => m (Maybe (ByteString, Maybe FileChunkStorage))
              -> m (Maybe ByteString)
-fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do
-  prewarm <- getsYesod appFileSourcePrewarm
-  let getChunkDB = case prewarm of
-        Nothing -> do
-          chunk' <- getChunkDB'
-          for chunk' $ \(chunk, mStorage) -> chunk <$ do
-            $logDebugS "fileChunkARC" "No prewarm"
-            for_ mStorage $ \storage ->
-              let w = length chunk
-               in liftIO $ observeSourcedChunk storage w
-        Just lh -> do
-          chunkRes <- lookupLRUHandle lh k 
-          case chunkRes of
-            Just (chunk, w) -> Just chunk <$ do
-              $logDebugS "fileChunkARC" "Prewarm hit"
-              liftIO $ observeSourcedChunk StoragePrewarm w
-            Nothing -> do
-              chunk' <- getChunkDB'
-              for chunk' $ \(chunk, mStorage) -> chunk <$ do
-                $logDebugS "fileChunkARC" "Prewarm miss"
-                for_ mStorage $ \storage ->
-                  let w = length chunk
-                   in liftIO $ observeSourcedChunk storage w
-  
-  arc <- getsYesod appFileSourceARC
-  case arc of
-    Nothing -> getChunkDB
-    Just ah -> do
-      cachedARC' ah k $ \case
-        Nothing -> do
-          chunk' <- case assertM (> l) altSize of
-            -- This optimization works for the somewhat common case that cdc chunks are smaller than db chunks and start of the requested range is aligned with a db chunk boundary
-            Just altSize'
-              -> fmap getFirst . execWriterT . cachedARC' ah (ref, (s, altSize')) $ \x -> x <$ case x of
-                   Nothing -> tellM $ First <$> getChunkDB
-                   Just (v, _) -> tell . First . Just $ ByteString.take l v
-            Nothing -> getChunkDB
-          for chunk' $ \chunk -> do
-            let w = length chunk
-            $logDebugS "fileChunkARC" "ARC miss"
-            return (chunk, w)
-        Just x@(_, w) -> do
-          $logDebugS "fileChunkARC" "ARC hit"
-          liftIO $ Just x <$ observeSourcedChunk StorageARC w
+fileChunk getChunkDB' = do
+  -- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained
+  chunk' <- getChunkDB'
+  for chunk' $ \(chunk, mStorage) -> chunk <$ do
+    $logDebugS "fileChunkARC" "No prewarm"
+    for_ mStorage $ \storage ->
+      let w = length chunk
+        in liftIO $ observeSourcedChunk storage w
 
 
-  
 sourceFileDB :: forall m.
                 (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
              => FileContentReference -> ConduitT () ByteString (SqlPersistT m) ()
@@ -119,12 +76,12 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe
         Nothing -> return Nothing
         Just start -> do
           let getChunkDB = cont (start, dbChunksize) . runMaybeT $
-                let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
+                let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do
                       E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
                       return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
                     getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold
                  in getChunkDB' <|> getChunkMinio
-          chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB
+          chunk <- fileChunk getChunkDB
           case chunk of
             Just c | olength c <= 0 -> return Nothing
             Just c -> do
@@ -191,7 +148,7 @@ sourceFile' = sourceFile . view (_FileReference . _1)
 
 instance (YesodMail UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => ToMailPart UniWorX FileReference where
   toMailPart = toMailPart <=< liftHandler . runDBRead . withReaderT projectBackend . toPureFile . sourceFile'
-  
+
 
 respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
                        => Maybe UTCTime -> MimeType
@@ -253,10 +210,10 @@ respondFileConditional representationLastModified cType FileReference{..} = do
                       forM_ relevantChunks $ \(chunkHash, offset, cLength)
                         -> let retrieveChunk = \case
                                  Just (start, cLength') | cLength' > 0 -> do
-                                   let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do
+                                   let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do
                                          E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
                                          return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
-                                   chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB
+                                   chunk <- fileChunk getChunkDB
                                    case chunk of
                                      Nothing -> throwM SourceFilesContentUnavailable
                                      Just c -> do
@@ -270,7 +227,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do
                   , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength)
                   )
             | otherwise -> throwM SourceFilesContentUnavailable
-            
+
     | otherwise
       -> return $ sendResponseStatus noContent204 ()
   where
@@ -281,7 +238,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do
       , requestedActionAlreadySucceeded = Nothing
       }
 
-byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) 
+byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification)
 byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange)
   where
     byteRange' = case byteRange of
@@ -293,7 +250,7 @@ byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange)
       ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t)
       ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength)
 
-  
+
 acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m')
 acceptFile fInfo = do
   let fileTitle = "." <//> unpack (fileName fInfo)

src/Handler/Utils/Form.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -16,16 +16,12 @@ import Utils.Form
 import Utils.Files
 
 import Handler.Utils.Form.Types
-
 import Handler.Utils.Pandoc
-
 import Handler.Utils.DateTime
-
 import Handler.Utils.I18n
-
 import Handler.Utils.Files
-
 import Handler.Utils.Exam
+import Handler.Utils.Memcached
 
 import Utils.Term
 
@@ -44,6 +40,7 @@ import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM)
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect)
+import Database.Persist.Sql.Raw.QQ
 
 import qualified Data.Set as Set
 import qualified Data.Sequence as Seq
@@ -2342,6 +2339,36 @@ examModeForm mPrev = examMode
             examRequiredEquipmentFromEither (Left  c) = ExamRequiredEquipmentCustom c
 
 
+roomReferenceSimpleField :: Field Handler RoomReference
+roomReferenceSimpleField =
+    convertField RoomReferenceSimple getRoom (textField & cfStrip & addDatalist roomReferenceSimpleSuggestions)
+  where
+    getRoom RoomReferenceSimple{..} = roomRefText
+    getRoom RoomReferenceLink{}     = mempty
+
+roomReferenceSimpleSuggestions :: HandlerFor UniWorX (OptionList Text)
+roomReferenceSimpleSuggestions = do
+  -- suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle <<$>> runDB
+  suggsRaw :: [Text] <- $(memcachedHere) (Just $ Right $ 42 * diffSecond) $ catchAllMonoid $ E.unSingle <<$>> runDB
+      [sqlQQ|
+        SELECT room FROM (
+          SELECT DISTINCT ON (room)
+              j.value #>> '{room,text}' AS room
+            , t.@{TutorialLastChanged} AS changed
+          FROM ^{Tutorial} AS t
+            , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j
+          ORDER BY 1, 2 DESC
+        ) AS sq
+        WHERE room IS NOT NULL
+        ORDER BY changed DESC
+        LIMIT 7;
+      |]
+  --  $logDebugS "Room" $ mconcat suggsRaw
+  return $ mkOptionList $ fmap (\t -> Option t t t) suggsRaw
+  -- suggs <- liftHandler $ runDBRead $ E.select $ do
+  --       tut <- E.from $ E.table @Tutorial
+  --     return $ tut E.^. tutorialTime E.#>>. ["scheduled","1","room","text"]
+
 roomReferenceFormOpt :: FieldSettings UniWorX
                      -> Maybe (Maybe RoomReference)
                      -> AForm Handler (Maybe RoomReference)
@@ -2378,7 +2405,7 @@ roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap clas
       Nothing -> pure Nothing
       Just RoomReferenceSimple' -> wFormToAForm $ do
         MsgRenderer mr <- getMsgRenderer
-        fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText)
+        fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip & addDatalist roomReferenceSimpleSuggestions) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText)
       Just RoomReferenceLink' -> wFormToAForm $ do
         MsgRenderer mr <- getMsgRenderer
         roomRefLink' <- wpreq urlField (fslI MsgRoomReferenceLinkLink & addPlaceholder (mr MsgRoomReferenceLinkLinkPlaceholder) & maybe id (\n -> addName $ n <> "__link") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefLink)

src/Handler/Utils/Form/Occurrences.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -8,6 +8,7 @@ module Handler.Utils.Form.Occurrences
 
 import Import
 import Handler.Utils.Form
+import Handler.Utils.Widgets
 import Handler.Utils.DateTime
 
 import qualified Data.Set as Set
@@ -58,8 +59,10 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
             (Map.fromList [ ( ScheduleKindWeekly
                             , ScheduleWeekly
                                 <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart   & addName (nudge "occur-start")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd     & addName (nudge "occur-end"  )) Nothing
+                                <*> roomReferenceFormOpt    (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing)
+                                --   <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) (Just Nothing)
                             )
                           ]
             ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
@@ -94,8 +97,10 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
             (Map.fromList [ ( ExceptionKindOccur
                             , ExceptOccur
                                 <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart   & addName (nudge "occur-start"))       Nothing
+                                <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd     & addName (nudge "occur-end"  ))       Nothing
+                                <*> roomReferenceFormOpt    (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing)
+                                --   <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing
                             )
                           , ( ExceptionKindNoOccur
                             , ExceptNoOccur

src/Handler/Utils/Memcached.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,10 +7,10 @@
 module Handler.Utils.Memcached
   ( memcachedAvailable
   , memcached, memcachedBy
+  , memcachedByClass, memcachedFlushClass, MemcachedKeyClass(..)
   , memcachedHere, memcachedByHere
   , memcachedSet, memcachedGet
-  , memcachedInvalidate, memcachedByInvalidate
-  , manageMemcachedLocalInvalidations
+  , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll
   , memcachedByGet, memcachedBySet
   , memcachedTimeout, memcachedTimeoutBy
   , memcachedTimeoutHere, memcachedTimeoutByHere
@@ -25,6 +25,15 @@ module Handler.Utils.Memcached
   , MemcachedException(..), AsyncTimeoutException(..)
   ) where
 
+{-  BEWARE: Keys for memcached use their Binary representation!
+
+    This means that the following three are all interchangeable as a key:
+      newtype Foo1 = Foo1 { someInt1 :: Int } deriving newtype (Binary)
+      data    Foo2 = Foo2 { someInt2 :: Int } deriving         (Binary)
+      type    Foo3 = Int
+    Therefore it is best to use $(memcachedHere) or $(memcachedByHere) if possible or add another type
+-}
+
 import Import.NoFoundation hiding (utc, exp)
 import Foundation.Type
 
@@ -40,13 +49,13 @@ import qualified Data.Binary.Get as Binary
 
 import Crypto.Hash.Algorithms (SHAKE256)
 
-import qualified Data.ByteArray as BA
+import qualified Data.Set as Set
 
-import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteArray as BA
 
 import Language.Haskell.TH hiding (Type)
 
-import Data.Typeable (typeRep, typeRepFingerprint)
+import Data.Typeable (typeRep)
 import Type.Reflection (typeOf, TypeRep)
 import qualified Type.Reflection as Refl (typeRep)
 import Data.Type.Equality (TestEquality(..))
@@ -69,10 +78,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
 
 import GHC.Fingerprint
 
-import Utils.Postgresql
-
-import UnliftIO.Concurrent (threadDelay)
-
 
 type Expiry = Either UTCTime DiffTime
 
@@ -166,72 +171,62 @@ memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
 
 memcachedByGet :: forall a k m.
                   ( MonadHandler m, HandlerSite m ~ UniWorX
-                  , Typeable a, Binary a, NFData a
+                  , Typeable a, Binary a
                   , Binary k
                   )
                => k -> m (Maybe a)
-memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache
-  where
-    arc = do
-      AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal
-      res <- hoistMaybe . preview (_1 . _NFDynamic) <=< hoistMaybe <=< cachedARC' memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) $ \mPrev -> do
-        prev@((_, prevExpiry), _) <- hoistMaybe mPrev
-        $logDebugS "memcached" "Cache hit (local ARC)"
-        lift . runMaybeT $ do -- To delete from ARC upon expiry
-          for_ prevExpiry $ \expiry -> do
+memcachedByGet (Binary.encode -> k) = runMaybeT $ do
+    AppMemcached{..} <- MaybeT $ getsYesod appMemcached
+    let cKey = toMemcachedKey memcachedKey (Proxy @a) k
+    encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn
+    --  $logDebugS "memcached" "Cache hit"
+
+    let withExp doExp = do
+          MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
+          $logDebugS "memcached" "Decode valid"
+          for_ mExpiry $ \expiry -> do
             now <- liftIO getPOSIXTime
-            guard $ expiry > now
-          return prev
-      $logDebugS "memcached" "All valid (local ARC)"
-      return res
-    memcache = do
-      AppMemcached{..} <- MaybeT $ getsYesod appMemcached
-      localARC <- getsYesod appMemcachedLocal
-      let cKey = toMemcachedKey memcachedKey (Proxy @a) k
+            guard $ expiry > now + clockLeniency
+          $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
+          let aad = memcachedAAD cKey mExpiry
+          decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
 
-      encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn
+          $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
 
-      $logDebugS "memcached" "Cache hit"
+          {-
+          let withCache = fmap (view _1) . ($ Nothing)
+          res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case
+            Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted
+            Just p -> return p
+          -}
+          hoistMaybe $ runGetMaybe Binary.get decrypted
 
-      let withExp doExp = do
-            MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
-            $logDebugS "memcached" "Decode valid"
-            for_ mExpiry $ \expiry -> do
-              now <- liftIO getPOSIXTime
-              guard $ expiry > now + clockLeniency
-            $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
-            let aad = memcachedAAD cKey mExpiry
-            decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
+    withExp True <|> withExp False
+  where
+    runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
+      Right (bs', _, x) | null bs' -> Just x
+      _other -> Nothing
 
-            $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
-      
-            let withCache = case localARC of
-                  Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k)
-                  Nothing -> fmap (view _1) . ($ Nothing)
-            res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case
-              Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted
-              Just p -> return p
-
-            $logDebugS "memcached" "All valid"
-
-            return res
-
-      withExp True <|> withExp False
-      where
-        runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
-          Right (bs', _, x) | null bs' -> Just x
-          _other -> Nothing
-        clockLeniency :: NominalDiffTime
-        clockLeniency = 2
+    clockLeniency :: NominalDiffTime
+    clockLeniency = 2
 
 memcachedBySet :: forall a k m.
                   ( MonadHandler m, HandlerSite m ~ UniWorX
                   , MonadThrow m
-                  , Typeable a, Binary a, NFData a
+                  , Typeable a, Binary a
                   , Binary k
                   )
                => Maybe Expiry -> k -> a -> m ()
-memcachedBySet mExp (Binary.encode -> k) v = do
+memcachedBySet = ((void .) .) . memcachedBySet'
+
+memcachedBySet' :: forall a k m.
+                  ( MonadHandler m, HandlerSite m ~ UniWorX
+                  , MonadThrow m
+                  , Typeable a, Binary a
+                  , Binary k
+                  )
+               => Maybe Expiry -> k -> a -> m (Maybe ByteString)
+memcachedBySet' mExp (Binary.encode -> k) v = do
   mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
 
   let decrypted = toStrict $ Binary.encode v
@@ -240,23 +235,14 @@ memcachedBySet mExp (Binary.encode -> k) v = do
     Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
 
   mConn <- getsYesod appMemcached
-  for_ mConn $ \AppMemcached{..} -> do
+  for mConn $ \AppMemcached{..} -> do
     mNonce <- liftIO AEAD.newNonce
     let cKey = toMemcachedKey memcachedKey (Proxy @a) k
         aad = memcachedAAD cKey mExpiry
         mCiphertext = AEAD.aead memcachedKey mNonce decrypted aad
     liftIO . handle (\(_ :: Memcached.MemcachedException) -> return ()) $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn
     $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
-
-  mLocal <- getsYesod appMemcachedLocal
-  for_ mLocal $ \AppMemcachedLocal{..} -> do
-    void . cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) . const $ return ((_NFDynamic # v, mExpiry), length decrypted)
-    $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry <> " (local ARC)"
-    -- DEBUG
-    let inv = Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..}
-          where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a
-                mLocalInvalidateKey = k
-    $logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv
+    return cKey
 
 memcachedByInvalidate :: forall a k m p.
                          ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -264,19 +250,11 @@ memcachedByInvalidate :: forall a k m p.
                          , Binary k
                          )
                       => k -> p a -> m ()
-memcachedByInvalidate (Binary.encode -> k) _ = arc >> memcache
-  where
-    memcache = maybeT_ $ do
-      AppMemcached{..} <- MaybeT $ getsYesod appMemcached
-      let cKey = toMemcachedKey memcachedKey (Proxy @a) k
-      hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn
-      $logDebugS "memcached" "Cache invalidation"
-    arc = maybeT_ $ do
-      AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal
-      let arcKey = (typeRepFingerprint . typeRep $ Proxy @a, k)
-      atomically $ modifyTVar' memcachedLocalInvalidationQueue (:> arcKey)
-      void . cachedARC' memcachedLocalARC arcKey . const $ return Nothing
-      $logDebugS "memcached" "Cache invalidation (local ARC)"
+memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
+  AppMemcached{..} <- MaybeT $ getsYesod appMemcached
+  let cKey = toMemcachedKey memcachedKey (Proxy @a) k
+  hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn
+  $logDebugS "memcached" "Cache invalidation"
 
 data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg
   { mLocalInvalidateType :: Fingerprint
@@ -293,7 +271,8 @@ instance Binary MemcachedLocalInvalidateMsg where
     Binary.putWord64le w1
     Binary.putWord64le w2
     Binary.putLazyByteString mLocalInvalidateKey
-  
+
+{-
 manageMemcachedLocalInvalidations :: ( MonadUnliftIO m
                                      , MonadLogger m
                                      )
@@ -316,22 +295,22 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager
       let (mLocalInvalidateType, mLocalInvalidateKey) = i
       return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..}
   }
+-}
 
-
-newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }  
+newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
   deriving newtype (Eq, Ord, Show, Binary)
 instance NFData a => NFData (MemcachedUnkeyed a) where
   rnf = rnf . unMemcachedUnkeyed
 
 memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX
-                , Typeable a, Binary a, NFData a
+                , Typeable a, Binary a
                 )
              => m (Maybe a)
 memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet ()
 
 memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , MonadThrow m
-                , Typeable a, Binary a, NFData a
+                , Typeable a, Binary a
                 )
              => Maybe Expiry -> a -> m ()
 memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
@@ -343,18 +322,16 @@ memcachedInvalidate :: forall (a :: Type) m p.
                     => p a -> m ()
 memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)
 
+memcachedFlushAll :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
+memcachedFlushAll = getsYesod appMemcached >>= flip whenIsJust (liftIO . Memcached.flushAll . memcachedConn)
 
 memcachedWith :: Monad m
               => (m (Maybe b), a -> m b) -> m a -> m b
-memcachedWith (doGet, doSet) act = do
-  pRes <- doGet
-  maybe id (const . return) pRes $ do
-    res <- act
-    doSet res
+memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet
 
 memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
              , MonadThrow m
-             , Typeable a, Binary a, NFData a
+             , Typeable a, Binary a
              )
           => Maybe Expiry -> m a -> m a
 memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
@@ -362,24 +339,66 @@ memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
 memcachedBy :: forall a m k.
                ( MonadHandler m, HandlerSite m ~ UniWorX
                , MonadThrow m
-               , Typeable a, Binary a, NFData a
+               , Typeable a, Binary a
                , Binary k
                )
             => Maybe Expiry -> k -> m a -> m a
 memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x)
 
 
-newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }  
+data MemcachedKeyClass
+    = MemcachedKeyClassTutorialOccurrences
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, NFData)
+  deriving anyclass (Hashable, Binary, Universe, Finite)
+
+newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStore :: Set ByteString }
+  deriving newtype (Eq, Ord, Semigroup, Monoid, Show, Binary, NFData)
+-- instance NFData MemcachedKeyClassStore where
+--   rnf MemcachedKeyClassStore{..} = rnf unMemcachedKeyClassStore
+
+memcachedByClass :: forall a m k.
+               ( MonadHandler m, HandlerSite m ~ UniWorX
+               , MonadThrow m
+               , Typeable a, Binary a
+               , Binary k
+               )
+            => MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a
+memcachedByClass mkc mExp k = memcachedWith (memcachedByGet k, setAndAddClass)
+  where
+    setAndAddClass v = do
+      mbKey <- memcachedBySet' mExp k v
+      whenIsJust mbKey $ \vKey -> do
+        cl <- maybeMonoid <$> memcachedByGet mkc
+        memcachedBySet Nothing mkc $ MemcachedKeyClassStore $ Set.insert vKey $ unMemcachedKeyClassStore cl
+        -- memcachedBySet Nothing mkc $ cl <> MemcachedKeyClassStore $ Set.singleton vKey
+      return v
+
+memcachedFlushClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m ()
+memcachedFlushClass mkc = maybeT_ $ do
+  AppMemcached{..} <- MaybeT $ getsYesod appMemcached
+  cl <- MaybeT $ memcachedByGet mkc
+  hoist liftIO $ forM_ (unMemcachedKeyClassStore cl) $
+    catchIfMaybeT Memcached.isKeyNotFound . flip Memcached.delete memcachedConn
+  lift $ memcachedByInvalidate mkc (Proxy @MemcachedKeyClassStore)
+
+newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }
   deriving newtype (Eq, Ord, Show, Binary)
 instance NFData a => NFData (MemcachedUnkeyedLoc a) where
   rnf MemcachedUnkeyedLoc{..} = rnf unMemcachedUnkeyedLoc
 
+-- avoids staging restictions
+withMemcachedUnkeyedLoc :: Functor f => (f (MemcachedUnkeyedLoc a) -> f (MemcachedUnkeyedLoc a)) -> (f a -> f a)
+withMemcachedUnkeyedLoc act = fmap unMemcachedUnkeyedLoc . act . fmap MemcachedUnkeyedLoc
+{-# INLINE withMemcachedUnkeyedLoc #-}
+
+-- Evaluates to: $(memcachedHere) :: forall a m. ( MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, Typeable a, Binary a)
+--                                   => Maybe Expiry -> m a -> m a
 memcachedHere :: Q Exp
 memcachedHere = do
   loc <- location
-  [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |]
+  [e| \mExp -> withMemcachedUnkeyedLoc (memcachedBy mExp loc) |]
 
-newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a }  
+newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a }
   deriving newtype (Eq, Ord, Show, Binary)
 instance NFData a => NFData (MemcachedKeyedLoc a) where
   rnf MemcachedKeyedLoc{..} = rnf unMemcachedKeyedLoc
@@ -392,6 +411,8 @@ withMemcachedKeyedLoc' :: (Functor f, Functor f') => (f (MemcachedKeyedLoc a) ->
 withMemcachedKeyedLoc' act = fmap (fmap unMemcachedKeyedLoc) . act . fmap MemcachedKeyedLoc
 {-# INLINE withMemcachedKeyedLoc' #-}
 
+-- Evaluates to: $(memcachedByHere) :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, Typeable a, Binary a, Binary k)
+--                                   => Maybe Expiry -> k -> m a -> m a
 memcachedByHere :: Q Exp
 memcachedByHere = do
   loc <- location
@@ -453,7 +474,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t
 memcachedLimited :: forall a m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadThrow m
-                    , Typeable a, Binary a, NFData a
+                    , Typeable a, Binary a
                     )
                  => Word64 -- ^ burst-size (tokens)
                  -> Word64 -- ^ avg. inverse rate (usec/token)
@@ -466,7 +487,7 @@ memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, me
 memcachedLimitedKey :: forall a k' m.
                        ( MonadHandler m, HandlerSite m ~ UniWorX
                        , MonadThrow m
-                       , Typeable a, Binary a, NFData a
+                       , Typeable a, Binary a
                        , Typeable k', Hashable k', Eq k'
                        )
                     => k'
@@ -481,7 +502,7 @@ memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedG
 memcachedLimitedBy :: forall a k m.
                      ( MonadHandler m, HandlerSite m ~ UniWorX
                       , MonadThrow m
-                      , Typeable a, Binary a, NFData a
+                      , Typeable a, Binary a
                       , Binary k
                       )
                    => Word64 -- ^ burst-size (tokens)
@@ -496,7 +517,7 @@ memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByG
 memcachedLimitedKeyBy :: forall a k' k m.
                          ( MonadHandler m, HandlerSite m ~ UniWorX
                          , MonadThrow m
-                         , Typeable a, Binary a, NFData a
+                         , Typeable a, Binary a
                          , Typeable k', Hashable k', Eq k'
                          , Binary k
                          )
@@ -534,7 +555,7 @@ memcachedLimitedKeyByHere = do
 memcacheAuth :: forall m k a.
                 ( MonadHandler m, HandlerSite m ~ UniWorX
                 , MonadThrow m
-                , Typeable a, Binary a, NFData a
+                , Typeable a, Binary a
                 , Binary k
                 )
              => k
@@ -555,7 +576,7 @@ memcacheAuth k mx = cachedByBinary k $ do
 memcacheAuth' :: forall a m k.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , MonadThrow m
-                 , Typeable a, Binary a, NFData a
+                 , Typeable a, Binary a
                  , Binary k
                  )
               => Expiry
@@ -563,11 +584,11 @@ memcacheAuth' :: forall a m k.
               -> m a
               -> m a
 memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
-  
+
 memcacheAuthMax :: forall m k a.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadThrow m
-                   , Typeable a, Binary a, NFData a
+                   , Typeable a, Binary a
                    , Binary k
                    )
                 => Expiry
@@ -585,7 +606,7 @@ memcacheAuthHere' :: Q Exp
 memcacheAuthHere' = do
   loc <- location
   [e| \exp k -> withMemcachedKeyedLoc (memcacheAuth' exp (loc, k)) |]
-  
+
 memcacheAuthHereMax :: Q Exp
 memcacheAuthHereMax = do
   loc <- location
@@ -681,7 +702,7 @@ memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadThrow m
                     , MonadUnliftIO m
                     , Typeable k'', Hashable k'', Eq k''
-                    , Typeable a, Binary a, NFData a
+                    , Typeable a, Binary a
                     )
                  => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a)
 memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp)
@@ -690,7 +711,7 @@ memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
                       , MonadThrow m
                       , MonadUnliftIO m
                       , Typeable k'', Hashable k'', Eq k''
-                      , Typeable a, Binary a, NFData a
+                      , Typeable a, Binary a
                       , Binary k
                       )
                    => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a)
@@ -711,7 +732,7 @@ memcachedLimitedTimeout :: forall a k'' m.
                            , MonadThrow m
                            , MonadUnliftIO m
                            , Typeable k'', Hashable k'', Eq k''
-                           , Typeable a, Binary a, NFData a
+                           , Typeable a, Binary a
                            )
                         => Word64 -- ^ burst-size (tokens)
                         -> Word64 -- ^ avg. inverse rate (usec/token)
@@ -728,7 +749,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m.
                               , MonadThrow m
                               , MonadUnliftIO m
                               , Typeable k'', Hashable k'', Eq k''
-                              , Typeable a, Binary a, NFData a
+                              , Typeable a, Binary a
                               , Typeable k', Hashable k', Eq k'
                               )
                            => k'
@@ -747,7 +768,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m.
                              , MonadThrow m
                              , MonadUnliftIO m
                              , Typeable k'', Hashable k'', Eq k''
-                             , Typeable a, Binary a, NFData a
+                             , Typeable a, Binary a
                              , Binary k
                              )
                           => Word64 -- ^ burst-size (tokens)
@@ -766,7 +787,7 @@ memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m.
                                 , MonadThrow m
                                 , MonadUnliftIO m
                                 , Typeable k'', Hashable k'', Eq k''
-                                , Typeable a, Binary a, NFData a
+                                , Typeable a, Binary a
                                 , Typeable k', Hashable k', Eq k'
                                 , Binary k
                                 )

src/Handler/Utils/Occurrences.hs

@@ -3,7 +3,11 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Handler.Utils.Occurrences
-  ( occurrencesWidget
+  ( LessonTime(..)
+  , lessonTimeWidget, lessonTimesWidget
+  , occurringLessons
+  , occurrencesWidget
+  , occurrencesCompute, occurrencesCompute'
   , occurrencesBounds
   , occurrencesAddBusinessDays
   ) where
@@ -16,10 +20,69 @@ import Utils.Holidays (isWeekend)
 import Utils.Occurrences
 
 import Handler.Utils.DateTime
+import Handler.Utils.Widgets (roomReferenceWidget)
+
+-- import Text.Read (read) -- for DEBUGGING only
 
 
-occurrencesWidget :: Occurrences -> Widget
-occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do
+----------------
+-- LessonTime --
+----------------
+--
+-- Model time intervals to compute lecture/tutorial lessons more intuitively
+--
+
+data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference }
+  deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set
+
+occurringLessons :: Term -> Occurrences -> Set LessonTime
+occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons
+  where
+    scheduledLessons      = occurrenceScheduleToLessons term `foldMap` occurrencesScheduled
+    (exceptOcc, exceptNo) = occurrenceExceptionToLessons  occurrencesExceptions
+    isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo
+
+occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime
+occurrenceScheduleToLessons Term{..} =
+  let setHolidays = Set.fromList termHolidays -- ensure that the conversion is performed only once for repeated calls
+  in \ScheduleWeekly{..} ->
+        let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays
+            toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart
+                                    , lessonEnd   = LocalTime d scheduleEnd
+                                    , lessonRoom  = scheduleRoom
+                                    }
+        in Set.map toLesson occDays
+
+occurrenceExceptionToLessons :: Set OccurrenceException -> (Set LessonTime, Set LocalTime)
+occurrenceExceptionToLessons = Set.foldr aux mempty
+  where
+    aux ExceptOccur{..} (oc,no) =
+      let t = LessonTime  { lessonStart = LocalTime exceptDay exceptStart
+                          , lessonEnd   = LocalTime exceptDay exceptEnd
+                          , lessonRoom  = exceptRoom
+                          }
+      in (Set.insert t oc,no)
+    aux ExceptNoOccur{..} (oc,no) =
+      (oc, Set.insert exceptTime no)
+
+lessonTimeWidget :: Bool -> LessonTime -> Widget
+lessonTimeWidget roomHidden LessonTime{..} = do
+  lStart <- formatTime SelFormatTime lessonStart
+  lEnd   <- formatTime SelFormatTime lessonEnd
+  $(widgetFile "widgets/lesson/single")
+
+lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget
+lessonTimesWidget roomHidden lessonsSet = do
+  let lessons = lessonTimeWidget roomHidden <$> lessonsSet
+  $(widgetFile "widgets/lesson/set")
+
+
+-----------------
+-- Occurrences --
+-----------------
+
+occurrencesWidget :: Bool -> JSONB Occurrences -> Widget
+occurrencesWidget roomHidden (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
   let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
         ScheduleWeekly{..} -> do
           scheduleStart' <- formatTime SelFormatTime scheduleStart
@@ -35,12 +98,14 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do
           $(widgetFile "widgets/occurrence/cell/except-no-occur")
   $(widgetFile "widgets/occurrence/cell")
 
--- | Get bounds for an Occurrences 
-occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day)
-occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays)    
-  where 
-    occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already
+-- | Get all days of occurrences during a term, excluding term holidays from the regular schedule, but not from do-occur exceptions
+occurrencesCompute :: Term -> Occurrences -> Set Day
+occurrencesCompute trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ
 
+-- | Less precise versison of `occurrencesCompute`, which ignores TimeOfDay; might be faster, but could be wrong in some cases
+occurrencesCompute' :: Term -> Occurrences -> Set Day
+occurrencesCompute' Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays
+  where
     scdDays = Set.foldr getOccDays mempty occurrencesScheduled
     (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions
 
@@ -51,6 +116,10 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM
     getOccDays :: OccurrenceSchedule -> Set Day -> Set Day
     getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday
 
+-- | Get bounds for an Occurrences
+occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day)
+occurrencesBounds = (liftM2 (,) Set.lookupMin Set.lookupMax .) . occurrencesCompute
+
 occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences
 occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions
   where
@@ -58,7 +127,7 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc
     dayDiff = diffDays dayNew dayOld
 
     offDays = Set.fromList $ termHolidays <> weekends
-    weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d]    
+    weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d]
 
     switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule
     switchDayOfWeek os | 0 == dayDiff `mod` 7 = os
@@ -74,6 +143,45 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc
           = advanceExceptions (succ offset, acc) ex
         | otherwise
           = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
-      where 
+      where
         ed = dayOfOccurrenceException ex
         nd = addDays offset ed
+
+
+
+{-
+
+-----------
+-- DEBUG --
+-----------
+theorieschulung :: Occurrences
+theorieschulung =
+   Occurrences
+    {occurrencesScheduled = Set.fromList
+      [ScheduleWeekly {scheduleDayOfWeek = Thursday, scheduleStart = read "11:11:00", scheduleEnd = read "12:22:00"}
+      ,ScheduleWeekly {scheduleDayOfWeek = Friday  , scheduleStart = read "13:33:00", scheduleEnd = read "14:44:00"}
+      ,ScheduleWeekly {scheduleDayOfWeek = Sunday  , scheduleStart = read "15:55:00", scheduleEnd = read "16:06:00"}
+      ]
+    , occurrencesExceptions = Set.fromList
+      [ExceptOccur {exceptDay = read "2024-01-07", exceptStart = read "08:30:00", exceptEnd = read "16:00:00"}
+      ,ExceptOccur {exceptDay = read "2024-01-15", exceptStart = read "09:00:00", exceptEnd = read "16:00:00"}
+      ,ExceptOccur {exceptDay = read "2024-09-24", exceptStart = read "09:10:00", exceptEnd = read "16:10:00"}
+      ,ExceptNoOccur {exceptTime = read "2024-02-25 15:55:00"}
+      ,ExceptNoOccur {exceptTime = read "2024-10-25 13:33:00"}
+      ,ExceptNoOccur {exceptTime = read "2024-11-08 08:08:08"} -- causes difference between occurrencesCompute and occurrencesCompute'
+      ,ExceptNoOccur {exceptTime = read "2024-11-09 11:11:08"}
+      ]
+    }
+
+exampleTerm :: Term
+exampleTerm = Term
+  { termName = TermIdentifier {year = 2024}
+  , termStart = read "2024-01-01"
+  , termEnd   = read "2024-12-29"
+  , termHolidays = [read "2024-01-01", read "2024-03-29", read "2024-03-31", read "2024-04-01", read "2024-05-01", read "2024-05-09"
+                   ,read "2024-05-19", read "2024-05-20", read "2024-05-30", read "2024-10-03", read "2024-12-24", read "2024-12-25", read "2024-12-26" ]
+  , termLectureStart = read "2024-01-01"
+  , termLectureEnd   = read "2024-12-27"
+  }
+
+-}

src/Handler/Utils/Qualification.hs

@@ -18,6 +18,38 @@ import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplic
 import qualified Database.Esqueleto.Utils as E
 
 import Handler.Utils.Widgets  (statusHtml)
+import Handler.Utils.Memcached
+
+
+retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
+retrieveQualification qid = liftHandler $ $(memcachedByHere) (Just . Right $ 7 * diffHour) qid $ runDBRead $ get qid
+
+{-
+This experiment proves that a newtype-wrapper is entirely ignored by the derived Binary instance, since
+regardless whether the prime or unprimed version is used, the same QualificationId leads to a hit:
+
+newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- unnecessary, also see top comment in Handler.Utils.Memcached
+  deriving newtype (Eq, Ord, Show, Binary)
+instance NFData MemcachedQualification where
+  rnf MemcachedQualification{..} = rnf unMemachedQualification
+
+-- note that data does not work as expected either, the binary instance is only distinguished by the addition of another element
+data MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- , someId :: Text } -- with Text works OK
+  deriving (Eq, Ord, Show, Generic, Binary)
+instance NFData MemcachedQualification where
+  rnf MemcachedQualification{..} = rnf (unMemachedQualification, someId)
+
+retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
+retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ do
+  $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} with Newtype-wrapper.|]
+  runDBRead $ get qid
+
+retrieveQualification' :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
+retrieveQualification' qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) qid $ do
+  $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} directly without a wrapper.|]
+  runDBRead $ get qid
+-}
+
 
 -- | Compute new valid date from old one and from validDuration in months
 --   Mainly to document which add months functions to use

src/Handler/Utils/Table/Cells.hs

@@ -14,7 +14,7 @@ import Handler.Utils.DateTime
 import Handler.Utils.Widgets
 import Handler.Utils.Occurrences
 import Handler.Utils.LMS (lmsUserStatusWidget)
-import Handler.Utils.Qualification (isValidQualification)
+import Handler.Utils.Qualification (isValidQualification, retrieveQualification)
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
@@ -48,10 +48,11 @@ addIndicatorCell = tellCell $ Any True
 writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
--- for documentation purposes
+-- for documentation purposes and better error message
 cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
 cellMaybe = foldMap
 
+-- for documentation purposes and better error message
 maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
 maybeCell = flip foldMap
 
@@ -383,7 +384,7 @@ companyIdCell cid = companyCell csh csh False
 qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c
 qualificationIdCell qid = anchorCellM' qual link name
   where
-    qual = liftHandler $ runDBRead $ get qid
+    qual = retrieveQualification qid
     link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
     link Nothing = HelpR
     name Nothing = text2widget "Error: unknown QID"
@@ -392,7 +393,7 @@ qualificationIdCell qid = anchorCellM' qual link name
 qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c
 qualificationIdShortCell qid = anchorCellM' qual link name
   where
-    qual = liftHandler $ runDBRead $ get qid
+    qual = retrieveQualification qid
     link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
     link Nothing = HelpR
     name Nothing = text2widget "Error: unknown QID"
@@ -509,11 +510,14 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
-occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a
-occurrencesCell = cell . occurrencesWidget
+lessonTimesCell :: IsDBTable m a => Bool -> [LessonTime] -> DBCell m a
+lessonTimesCell roomHidden lessons = cell $ lessonTimesWidget roomHidden lessons
+
+occurrencesCell :: IsDBTable m a => Bool -> JSONB Occurrences -> DBCell m a
+occurrencesCell roomHidden occs = cell $ occurrencesWidget roomHidden occs
 
 roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a
-roomReferenceCell = cell . roomReferenceWidget
+roomReferenceCell = cell . roomReferenceShortWidget
 
 cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
 cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece

src/Handler/Utils/Table/Columns.hs

@@ -8,7 +8,7 @@ module Handler.Utils.Table.Columns where
 
 import Import hiding (link)
 
-import qualified Data.Map as Map
+-- import qualified Data.Map as Map
 
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E hiding ((->.))
@@ -195,9 +195,9 @@ colExamLabel resultLabel = Colonnade.singleton (fromSortable header) body
 sortExamLabel :: OpticSortColumn (Maybe ExamOfficeLabelName)
 sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel
 
----------------------
--- Exam occurences --
----------------------
+----------------------
+-- Exam occurrences --
+----------------------
 
 colOccurrenceStart :: OpticColonnade UTCTime
 colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body
@@ -830,8 +830,8 @@ fltrCompanyNameNrHdrUI msg mPrev =
 
 
 fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k)
-              => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs)
-fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
+              => (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs)
+fltrAVSCardNos queryUser = ("avs-card", fch)
   where
     fch = FilterColumnHandler $ \case
       [] -> return (const E.true)

src/Handler/Utils/Table/Pagination.hs

@@ -61,6 +61,7 @@ module Handler.Utils.Table.Pagination
   , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
+  , listInlineCell, listInlineCell', ilistInlineCell, ilistInlineCell'
   , formCell, DBFormResult(..), getDBFormResult
   , dbSelect, dbSelectIf
   , (&)
@@ -1853,6 +1854,22 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
       toWidget $ x2widgetUnauth Nothing
 
 
+listInlineCell :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell = listInlineCell' . return
+
+listInlineCell' :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell' mkXS mkCell = ilistInlineCell' (otoList <$> mkXS) $ const mkCell
+
+ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell = ilistInlineCell' . return
+
+ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell' mkXS mkCell = review dbCell . ([], ) $ do
+  xs <- mkXS
+  cells <- forM (otoKeyedList $ reverse xs) $ -- Do we need to reverse for all MonoFoldableWithKey, or is only the List-Instance flawed?
+    \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+  return $(widgetFile "table/cell/listInline")
+
 listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
 listCell = listCell' . return
 

src/Handler/Utils/Term.hs

@@ -16,7 +16,7 @@ import qualified Data.Set as Set
 import qualified Data.Sequence as Seq
 
 import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Utils as E
 
 import Utils.Term
 
@@ -41,7 +41,7 @@ getCurrentTerm :: MonadIO m => SqlReadT m (Maybe TermId)
 -- ^ Current, generally active, term (i.e. `termIsActiveE` with `Nothing` as `maybeAuthId`)
 getCurrentTerm = do
   now <- liftIO getCurrentTime
-  fmap (fmap E.unValue) . E.selectMaybe . E.from $ \term -> do
+  fmap (fmap E.unValue) . E.selectOne . E.from $ \term -> do
     E.where_ . termIsActiveE (E.val now) E.nothing $ term E.^. TermId
     E.orderBy [E.desc $ term E.^. TermName]
     return $ term E.^. TermId
@@ -64,7 +64,7 @@ getActiveTerms = do
     E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList
 
 fetchTermByCID :: ( MonadHandler m
-                  , BackendCompatible SqlBackend backend                  
+                  , BackendCompatible SqlBackend backend
                   , PersistQueryRead backend, PersistUniqueRead backend
                   )
               => CourseId -> ReaderT backend m Term

src/Handler/Utils/Users.hs

@@ -704,7 +704,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamRegistrationUser ==. oldUserId ]
 
   do
-    collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
+    collision <- E.selectOne . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
       EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
        E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
        E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
@@ -726,7 +726,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   deleteWhere [ ExamPartResultUser ==. oldUserId ]
 
   do
-    collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
+    collision <- E.selectOne . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
       EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
        E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
        E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
@@ -816,7 +816,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
    in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
 
   do
-    collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
+    collision <- E.selectOne . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
       EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
        E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
@@ -852,7 +852,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (\_current _excluded -> [])
 
   do
-    collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
+    collision <- E.selectOne . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
       EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
       EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
        E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
@@ -870,9 +870,31 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         return $ TutorialParticipant
           E.<#  (tutorialParticipant E.^. TutorialParticipantTutorial)
           E.<&> E.val newUserId
+          E.<&> (tutorialParticipant E.^. TutorialParticipantCompany)
+          E.<&> (tutorialParticipant E.^. TutorialParticipantDrivingPermit)
+          E.<&> (tutorialParticipant E.^. TutorialParticipantEyeExam)
+          E.<&> (tutorialParticipant E.^. TutorialParticipantNote)
     )
     (\_current _excluded -> [])
-  deleteWhere [ TutorialParticipantUser ==. oldUserId ]
+  E.insertSelectWithConflict
+    UniqueTutorialParticipantDay
+    (EL.from $ \tutorialParticipantDay -> do
+        E.where_ $ tutorialParticipantDay E.^. TutorialParticipantDayUser E.==. E.val oldUserId
+        return $ TutorialParticipantDay
+          E.<#  (tutorialParticipantDay E.^. TutorialParticipantDayTutorial)
+          E.<&> E.val newUserId
+          E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayDay)
+          E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayAttendance)
+          E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayNote)
+    )
+    (\current excluded ->
+      [ TutorialParticipantDayAttendance E.=. (current E.^. TutorialParticipantDayAttendance E.||. excluded E.^. TutorialParticipantDayAttendance)
+      , TutorialParticipantDayNote       E.=. E.coalesce [current E.^. TutorialParticipantDayNote, excluded E.^. TutorialParticipantDayNote]
+      ]
+    )
+  deleteWhere [ TutorialParticipantDayUser ==. oldUserId ]
+  deleteWhere [ TutorialParticipantUser    ==. oldUserId ]
+
 
   E.insertSelectWithConflict
     UniqueSystemMessageHidden
@@ -1011,6 +1033,21 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     )
   deleteWhere [ UserCompanyUser ==. oldUserId]
 
+  E.insertSelectWithConflict
+    UniqueUserDay
+    (EL.from $ \userDay -> do
+      E.where_ $ userDay E.^. UserDayUser E.==. E.val oldUserId
+      return $ UserDay
+        E.<# E.val newUserId
+        E.<&> (userDay E.^. UserDayDay)
+        E.<&> (userDay E.^. UserDayParkingToken)
+    )
+    (\current excluded ->
+      [ UserDayParkingToken E.=. (current E.^. UserDayParkingToken E.||. excluded E.^. UserDayParkingToken)
+      ]
+    )
+  deleteWhere [ UserDayUser ==. oldUserId]
+
   mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
   mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
   case (mbOldAvsId,mbNewAvsId) of

src/Handler/Utils/Widgets.hs

@@ -293,8 +293,15 @@ examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets
 
 
 roomReferenceWidget :: RoomReference -> Widget
-roomReferenceWidget RoomReferenceSimple{..} = toWidget roomRefText
-roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link")
+roomReferenceWidget RoomReferenceSimple{..} = msg2widget $ MsgRoomReferenceSimpleAt roomRefText
+roomReferenceWidget RoomReferenceLink{..}   = $(widgetFile "widgets/room-reference/link")
+  where
+    linkText = uriToString id roomRefLink mempty
+    instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
+
+roomReferenceShortWidget :: RoomReference -> Widget
+roomReferenceShortWidget RoomReferenceSimple{..} = text2widget roomRefText
+roomReferenceShortWidget RoomReferenceLink{..}   = $(widgetFile "widgets/room-reference/link")
   where
     linkText = uriToString id roomRefLink mempty
     instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")

src/Import/NoModel.hs

@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Import.NoModel
   ( module Import
   , MForm

src/Jobs.hs

@@ -18,7 +18,6 @@ import Jobs.Offload
 import Jobs.Crontab
 
 import qualified Data.Conduit.Combinators as C
-import qualified Data.Conduit.List as C (mapMaybe)
 
 import qualified Data.Text.Lazy as LT
 
@@ -52,15 +51,6 @@ import Control.Concurrent.STM.Delay
 
 import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
 
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-
-import qualified Data.ByteString as ByteString
-
-import Handler.Utils.Files (sourceFileChunks, _SourceFilesContentUnavailable)
-
-import qualified Data.IntervalMap.Strict as IntervalMap
-
 import Jobs.Handler.SendNotification
 import Jobs.Handler.SendTestEmail
 import Jobs.Handler.QueueNotification
@@ -91,7 +81,7 @@ import Type.Reflection (typeOf)
 
 import System.Clock
 
-  
+
 data JobQueueException = JInvalid QueuedJobId QueuedJob
                        | JLocked QueuedJobId InstanceId UTCTime
                        | JNonexistant QueuedJobId
@@ -188,7 +178,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
       let
         routeExc :: forall m'. Monad m' => (forall b. m b -> m b) -> m (m' ()) -> m (m' ())
         routeExc unmask' = handleAll (\exc -> return () <$ throwTo me exc) . unmask'
-  
+
       actAsync <- allocateLinkedAsyncWithUnmask $ \unmask' -> act (routeExc unmask')
 
       let handleExc e = do
@@ -196,12 +186,12 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
             atomically $ do
               jState <- tryReadTMVar appJobState
               for_ jState $ \JobState{jobShutdown} -> tryPutTMVar jobShutdown ()
-            
+
             void $ wait actAsync
             throwM e
-  
+
       unmask (wait actAsync) `catchAll` handleExc
-    
+
     num :: Int
     num = fromIntegral $ foundation ^. _appJobWorkers
 
@@ -209,7 +199,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
     spawnMissingWorkers = do
       shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
       guard $ not shouldTerminate'
-  
+
       oldState <- takeTMVar appJobState
       let missing = num - Map.size (jobWorkers oldState)
       guard $ missing > 0
@@ -266,7 +256,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
                   atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
                   go
            in go
-        
+
     terminateGracefully :: (() -> ContT () m ()) -> STM (ContT () m ())
     terminateGracefully terminate = do
       shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
@@ -329,7 +319,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
       respawn <$ case cOffload of
         Nothing -> return ()
         Just JobOffloadHandler{..} -> waitSTM jobOffloadHandler
-      
+
 
 stopJobCtl :: MonadUnliftIO m => UniWorX -> m ()
 -- ^ Stop all worker threads currently running
@@ -388,7 +378,7 @@ execCrontab = do
 
   let doJob = mapRWST (liftHandler . runDBJobs) $ do
         -- newCrontab <- lift $ hoist lift determineCrontab'
-        -- when (newCrontab /= currentCrontab) $ 
+        -- when (newCrontab /= currentCrontab) $
         --   mapRWST (liftIO . atomically) $
         --     liftBase . flip writeTVar newCrontab =<< asks (jobCrontab . jobContext)
         newCrontab <- liftIO . readTVarIO =<< asks (jobCrontab . jobContext)
@@ -407,7 +397,7 @@ execCrontab = do
           case jobCtl of
             JobCtlQueue job -> lift $ queueDBJobCron job
             other -> runReaderT ?? foundation $ writeJobCtl other
-  
+
   case nextMatch of
     MatchAsap -> doJob
     MatchNone -> return ()
@@ -497,7 +487,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
 #endif
       , Exc.Handler $ \(e :: SomeException) -> return $ Left e
       ] . fmap Right
-    
+
     handleQueueException :: MonadLogger m => JobQueueException -> m ()
     handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
     handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
@@ -586,7 +576,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
       liftHandler . runDB $ pruneLastExecs newCTab
       $logInfoS logIdent "PruneLastExecs"
       -- logDebugS logIdent $ tshow newCTab
-      mapReaderT (liftIO . atomically) $ 
+      mapReaderT (liftIO . atomically) $
         lift . flip writeTVar newCTab =<< asks jobCrontab
     handleCmd (JobCtlGenerateHealthReport kind) = do
       hrStorage <- getsYesod appHealthReport
@@ -596,7 +586,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
       $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|]
       unless (newStatus > HealthFailure) $ do
         $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|]
-  
+
       liftIO $ do
         now <- getCurrentTime
         let updateReports = Set.insert (now, newReport)
@@ -606,69 +596,6 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
       $logInfoS logIdent [st|Sleeping #{tshow secs}s...|]
       threadDelay msecs
       $logInfoS logIdent [st|Slept #{tshow secs}s.|]
-    handleCmd JobCtlPrewarmCache{..} = do
-      prewarm <- getsYesod appFileSourcePrewarm
-      for_ prewarm $ \lh -> lift . runDBRead $
-        runConduit $ sourceFileChunkIds .| C.map E.unValue
-                  .| awaitForever (\cRef -> handleC handleUnavailable $ sourceFileChunks (withLRU lh cRef) cRef .| C.map (cRef, ))
-                  .| C.mapM_ (sinkChunkCache lh)
-      where
-        handleUnavailable e
-          | is _SourceFilesContentUnavailable e = return ()
-          | otherwise = throwM e
-        withLRU lh cRef range getChunk = do
-          touched <- touchLRUHandle lh (cRef, range) jcTargetTime
-          case touched of
-            Just (bs, _) -> return $ Just (bs, Nothing)
-            Nothing -> over (mapped . _2) Just <$> getChunk
-        (minBoundDgst, maxBoundDgst) = jcChunkInterval
-        sourceFileChunkIds = E.selectSource . E.from $ \fileContentEntry -> do
-          let cRef = fileContentEntry E.^. FileContentEntryChunkHash
-              eRef = fileContentEntry E.^. FileContentEntryHash
-          E.where_ . E.and $ catMaybes
-            [ minBoundDgst <&> \b -> cRef E.>=. E.val b
-            , maxBoundDgst <&> \b -> cRef E.<.  E.val b
-            ]
-          E.where_ $ matchesPrewarmSource eRef jcPrewarmSource
-          return cRef
-        sinkChunkCache lh (cRef, (c, range)) = insertLRUHandle lh (cRef, range) jcTargetTime (c, ByteString.length c)
-    handleCmd JobCtlInhibitInject{..} = maybeT_ $ do
-      PrewarmCacheConf{..} <- MaybeT . getsYesod $ view _appFileSourcePrewarmConf
-      let inhibitInterval = IntervalMap.ClosedInterval
-            (addUTCTime (-precStart) jcTargetTime)
-            (addUTCTime (precInhibit - precStart) jcTargetTime)
-          sourceFileReferences = prewarmSourceReferences jcPrewarmSource
-      refs <- lift . lift . runDBRead . runConduit $ sourceFileReferences .| C.foldl (flip Set.insert) Set.empty
-      guard . not $ null refs
-      inhibitTVar <- getsYesod appFileInjectInhibit
-      atomically . modifyTVar' inhibitTVar $ force . IntervalMap.insertWith Set.union inhibitInterval refs
-
-matchesPrewarmSource :: E.SqlExpr (E.Value FileContentReference) -> JobCtlPrewarmSource -> E.SqlExpr (E.Value Bool)
-matchesPrewarmSource eRef = \case
-  JobCtlPrewarmSheetFile{..} -> E.or
-    [ E.exists . E.from $ \sheetFile ->
-        E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val jcpsSheet
-             E.&&. sheetFile E.^. SheetFileType E.==. E.val jcpsSheetFileType
-             E.&&. sheetFile E.^. SheetFileContent E.==. E.just eRef
-    , E.exists . E.from $ \personalisedSheetFile ->
-        E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. E.val jcpsSheet
-             E.&&. personalisedSheetFile E.^. PersonalisedSheetFileType E.==. E.val jcpsSheetFileType
-             E.&&. personalisedSheetFile E.^. PersonalisedSheetFileContent E.==. E.just eRef
-    ]
-
-prewarmSourceReferences :: JobCtlPrewarmSource -> ConduitT () FileContentReference (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
-prewarmSourceReferences = \case
-  JobCtlPrewarmSheetFile{..} -> (.| C.mapMaybe E.unValue) $ do
-    E.selectSource . E.from $ \sheetFile -> do
-      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val jcpsSheet
-           E.&&. sheetFile E.^. SheetFileType E.==. E.val jcpsSheetFileType
-      E.where_ . E.isJust $ sheetFile E.^. SheetFileContent
-      return $ sheetFile E.^. SheetFileContent
-    E.selectSource . E.from $ \personalisedSheetFile -> do
-      E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. E.val jcpsSheet
-           E.&&. personalisedSheetFile E.^. PersonalisedSheetFileType E.==. E.val jcpsSheetFileType
-      E.where_ . E.isJust $ personalisedSheetFile E.^. PersonalisedSheetFileContent
-      return $ personalisedSheetFile E.^. PersonalisedSheetFileContent
 
 jLocked :: QueuedJobId -> (Entity QueuedJob -> ReaderT JobContext Handler a) -> ReaderT JobContext Handler a
 jLocked jId act = flip evalStateT False $ do
@@ -707,7 +634,7 @@ jLocked jId act = flip evalStateT False $ do
         update jId' [ QueuedJobLockInstance =. Nothing
                     , QueuedJobLockTime =. Nothing
                     ]
-      
+
   bracket lock unlock $ lift . act
 
 
@@ -723,7 +650,7 @@ pruneLastExecs crontab = do
     ensureCrontab (Entity leId CronLastExec{..}) = maybeT (return mempty) $ do
       now <- liftIO getCurrentTime
       flushInterval <- MaybeT . getsYesod . view $ appSettings . _appJobFlushInterval
-  
+
       if
         | abs (now `diffUTCTime` cronLastExecTime) > flushInterval * 2
           -> return mempty

src/Jobs/Crontab.hs

@@ -27,17 +27,6 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 
-import Jobs.Handler.Intervals.Utils
-
-import System.IO.Unsafe
-
-import Crypto.Hash (hashDigestSize, digestFromByteString)
-
-import Data.List (iterate)
-
-{-# NOINLINE prewarmCacheIntervalsCache #-}
-prewarmCacheIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)])
-prewarmCacheIntervalsCache = unsafePerformIO $ newTVarIO Map.empty
 
 determineCrontab :: ReaderT SqlReadBackend (HandlerFor UniWorX) (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
@@ -66,51 +55,9 @@ determineCrontab = execWriterT $ do
           }
       Nothing  -> mempty
 
-  let
-    tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
-    tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT_ $ do
-      PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf
-
-      let
-        chunkHashBytes :: forall h.
-                         ( Unwrapped FileContentChunkReference ~ Digest h )
-                      => Integer
-        chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h))
-      intervals <- mkIntervalsCached prewarmCacheIntervalsCache chunkHashBytes (fmap (review _Wrapped) . digestFromByteString) precSteps
-
-      let step = realToFrac $ toRational (precStart - precEnd) / toRational precSteps
-          step' = realToFrac $ toRational step / precMaxSpeedup
-
-      mapM_ tell
-        [ HashMap.singleton
-            JobCtlPrewarmCache{..}
-            Cron
-              { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ ts
-              , cronRepeat = CronRepeatOnChange
-              , cronRateLimit = step'
-              , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ ts'
-              }
-        | jcChunkInterval <- intervals
-        | ts <- iterate (addUTCTime step) $ addUTCTime (-precStart) jcTargetTime
-        | ts' <- iterate (addUTCTime step') $ addUTCTime (subtract precStart . realToFrac $ toRational (precStart - precEnd) * (1 - recip precMaxSpeedup)) jcTargetTime
-        ]
-
-      lift . maybeT_ $ do
-        injectInterval <- fmap abs . MaybeT . getsYesod $ view _appInjectFiles
-        tell $ HashMap.singleton
-          JobCtlInhibitInject{..}
-          Cron
-            { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (negate $ precStart + injectInterval + 10) jcTargetTime
-            , cronRepeat = CronRepeatScheduled CronAsap
-            , cronRateLimit = injectInterval / 2
-            , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (precInhibit - precStart) jcTargetTime
-            }
-
   let
     sheetJobs (Entity nSheet Sheet{..}) = do
-      for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do
-        tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom
-
+      for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom ->
         when (isn't _JobsOffload appJobMode) $ do
           tell $ HashMap.singleton
             (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
@@ -120,9 +67,7 @@ determineCrontab = execWriterT $ do
               , cronRateLimit = appNotificationRateLimit
               , cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
               }
-      for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> do
-        tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetHint) hFrom
-
+      for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom ->
         when (isn't _JobsOffload appJobMode) . maybeT_ $ do
           guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom
           guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom)
@@ -136,9 +81,7 @@ determineCrontab = execWriterT $ do
               , cronRateLimit = appNotificationRateLimit
               , cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo
               }
-      for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> do
-        tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetSolution) sFrom
-
+      for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom ->
         when (isn't _JobsOffload appJobMode) . maybeT_ $ do
           guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom
           guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet]

src/Jobs/Handler/Files.hs

@@ -44,13 +44,6 @@ import qualified Data.Sequence as Seq
 
 import Jobs.Handler.Intervals.Utils
 
-import Data.IntervalMap.Strict (IntervalMap)
-import qualified Data.IntervalMap.Strict as IntervalMap
-
-import Control.Concurrent.STM.TVar (stateTVar)
-
-import qualified Data.Foldable as F
-
 import qualified Control.Monad.State.Class as State
 
 import Jobs.Types
@@ -96,7 +89,7 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
 
       missingDb <- runConduit . execStateC Map.empty $ do
         let insertRef refKind ref = State.modify' $ Map.alter (Just . Set.insert ref . fromMaybe Set.empty) refKind
-        
+
         iforM_ trackedReferences $ \refKind refQuery -> do
           let fileReferencesQuery = do
                 ref <- refQuery
@@ -152,7 +145,7 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
       , (''SubmissionFile,           E.from $ \subFile               -> return $ subFile               E.^. SubmissionFileContent          )
       , (''SessionFile,              E.from $ \sessFile              -> return $ sessFile              E.^. SessionFileContent             )
       ]
-      
+
 
 
 {-# NOINLINE pruneUnreferencedFilesIntervalsCache #-}
@@ -208,12 +201,12 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
             let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
             E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
               E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
-              return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs 
+              return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
             E.where_ $ chunkIdFilter unreferencedChunkHash
           unmarkRefSource refSource = runConduit $ refSource .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkSourceFiles
           chunkSize = 100
       unmarkRefSource   jobFileReferences
-  
+
       let
         getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
           let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do
@@ -277,16 +270,7 @@ dispatchJobInjectFiles :: JobHandler UniWorX
 dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do
   uploadBucket <- getsYesod $ view _appUploadCacheBucket
   interval <- getsYesod $ view _appInjectFiles
-
-  now <- liftIO getCurrentTime
-  let
-    extractInhibited :: IntervalMap UTCTime (Set FileContentReference)
-                     -> (Set FileContentReference, IntervalMap UTCTime (Set FileContentReference))
-    extractInhibited cState = (F.fold current, IntervalMap.union current upcoming)
-      where
-        (_, current, upcoming) = IntervalMap.splitIntersecting cState $ IntervalMap.OpenInterval (addUTCTime (-2) now) (addUTCTime 2 now)
-  inhibited <- atomically . flip stateTVar extractInhibited =<< getsYesod appFileInjectInhibit
-
+  -- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained
   let
     extractReference (Minio.ListItemObject oi) = (oi, ) <$> Minio.oiObject oi ^? minioFileReference
     extractReference _ = Nothing
@@ -296,7 +280,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do
     injectOrDelete (objInfo, fRef) = do
       let obj = Minio.oiObject objInfo
           sz  = fromIntegral $ max 1 $ Minio.oiSize objInfo
-      
+
       fRef' <- runDB $ do
         logger <- askLoggerIO
 
@@ -352,7 +336,6 @@ dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do
   (Sum injectedFiles, Sum injectedSize) <-
     runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True)
               .| C.mapMaybe extractReference
-              .| C.filter (views _2 (`Set.notMember` inhibited))
               .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
               .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
               .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFilesCount $ const 1)
@@ -368,7 +351,7 @@ data RechunkFileException
       { oldHash, newHash :: FileContentReference }
   deriving (Eq, Ord, Show, Generic)
   deriving anyclass (Exception)
-    
+
 dispatchJobRechunkFiles :: JobHandler UniWorX
 dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin
   where

src/Jobs/Types.hs

@@ -9,8 +9,7 @@ module Jobs.Types
   ( Job(..), Notification(..)
   , JobChildren
   , classifyJob
-  , JobCtlPrewarmSource(..), _jcpsSheet, _jcpsSheetFileType
-  , JobCtl(..), _jcPrewarmSource, _jcChunkInterval
+  , JobCtl(..)
   , classifyJobCtl
   , YesodJobDB
   , JobHandler(..), _JobHandlerAtomic, _JobHandlerException
@@ -218,34 +217,8 @@ classifyJob job = unpack tag
     Aeson.String tag = obj HashMap.! "job"
 
 
-data JobCtlPrewarmSource
-  = JobCtlPrewarmSheetFile
-    { jcpsSheet :: SheetId
-    , jcpsSheetFileType :: SheetFileType
-    }
-  deriving (Eq, Ord, Read, Show, Generic)
-  deriving anyclass (Hashable, NFData)
-
-makeLenses_ ''JobCtlPrewarmSource
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 3
-  , fieldLabelModifier = camelToPathPiece' 1
-  , tagSingleConstructors = True
-  , sumEncoding = TaggedObject "source" "data"
-  } ''JobCtlPrewarmSource
-
 data JobCtl = JobCtlFlush
             | JobCtlPerform QueuedJobId
-            | JobCtlPrewarmCache
-                { jcPrewarmSource :: JobCtlPrewarmSource
-                , jcTargetTime    :: UTCTime
-                , jcChunkInterval :: (Maybe FileContentChunkReference, Maybe FileContentChunkReference)
-                }
-            | JobCtlInhibitInject
-                { jcPrewarmSource :: JobCtlPrewarmSource
-                , jcTargetTime    :: UTCTime
-                }
             | JobCtlDetermineCrontab
             | JobCtlQueue Job
             | JobCtlGenerateHealthReport HealthCheck

src/Model.hs

@@ -29,7 +29,6 @@ import Database.Persist.Sql (BackendKey(..))
 
 import qualified Database.Esqueleto.Legacy as E
 
-
 type SqlBackendKey = BackendKey SqlBackend
 
 
@@ -56,7 +55,7 @@ deriving newtype instance FromJSONKey ExamOccurrenceId
 deriving newtype instance ToSample UserId
 deriving newtype instance ToSample ExternalApiId
 
--- required Show instances for use of getByJust 
+-- required Show instances for use of getByJust
 deriving instance Show (Unique ExamPart)
 deriving instance Show (Unique QualificationUser)
 deriving instance Show (Unique LmsUser)
@@ -146,7 +145,7 @@ instance IsFileReference PersonalisedSheetFile where
   fileReferenceTitleField    = PersonalisedSheetFileTitle
   fileReferenceContentField  = PersonalisedSheetFileContent
   fileReferenceModifiedField = PersonalisedSheetFileModified
- 
+
 instance HasFileReference SubmissionFile where
   data FileReferenceResidual SubmissionFile = SubmissionFileResidual
     { submissionFileResidualSubmission :: SubmissionId
@@ -247,5 +246,5 @@ instance IsFileReference MaterialFile where
 deriveJSON  defaultOptions
   { tagSingleConstructors = False
   , fieldLabelModifier     = camelToPathPiece' 2
-  , omitNothingFields = True  
+  , omitNothingFields = True
   } ''QualificationUserBlock

src/Model/Migration/Definitions.hs

@@ -48,9 +48,10 @@ import qualified Data.Time.Zones as TZ
 
 data ManualMigration
   = Migration20230524QualificationUserBlock
-  | Migration20230703LmsUserStatus    
+  | Migration20230703LmsUserStatus
   | Migration20240212InitInterfaceHealth        -- create table interface_health and fill with default values
-  | Migration20240224UniquenessCompanyAvsNr  
+  | Migration20240224UniquenessCompanyAvsNr
+  | Migration20240930RoomOccurrences            -- rooms become a part of occurrences
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -89,16 +90,18 @@ migrateManual = do
     , ("study_features_relevance_cached",     "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)")
     , ("submission_rating_by",                "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL"  )
     , ("exam_corrector_user",                 "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")"                            )
-    , ("submission_rating_time",              "CREATE INDEX submission_rating_time ON submission (rating_time)"                          )    
+    , ("submission_rating_time",              "CREATE INDEX submission_rating_time ON submission (rating_time)"                          )
     , ("idx_qualification_user_first_held"   ,"CREATE INDEX idx_qualification_user_first_held ON \"qualification_user\" (\"first_held\")")
     , ("idx_qualification_user_valid_until"  ,"CREATE INDEX idx_qualification_user_valid_until ON \"qualification_user\" (\"valid_until\")")
     , ("idx_qualification_user_block_quser"  ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")")
     , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
-    , ("idx_qualification_user_block_from"   ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")    
-    , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")    
+    , ("idx_qualification_user_block_from"   ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")
+    , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
     , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
     , ("idx_user_company_company"            ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
-    , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user    
+    , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user
+    , ("idx_tutorial_time"                   ,"CREATE INDEX idx_tutorial_time ON \"tutorial\" USING GIN (\"time\")")            -- GIN Index to speed up filtering with @>.
+    , ("idx_course_event_time"               ,"CREATE INDEX idx_course_event_time ON \"course_event\" USING GIN (\"time\")")    -- GIN Index to speed up filtering with @>.
     ]
   where
     addIndex :: Text -> Sql -> Migration
@@ -142,17 +145,17 @@ customMigrations = mapF $ \case
 
   Migration20230524QualificationUserBlock ->
     whenM (andM [ not <$> tableExists "qualification_user_block"
-                , tableExists  "qualification_user" 
-                , columnExists "qualification_user" "blocked_due" 
+                , tableExists  "qualification_user"
+                , columnExists "qualification_user" "blocked_due"
                 ] ) $ do
         [executeQQ|
-          CREATE TABLE "qualification_user_block" 
+          CREATE TABLE "qualification_user_block"
             ( "id" SERIAL8 PRIMARY KEY UNIQUE
             , "qualification_user" bigint NOT NULL
             , "unblock" boolean NOT NULL
             , "from" timestamp with time zone NOT NULL
             , "reason" character varying NOT NULL
-            , "blocker" bigint 
+            , "blocker" bigint
             , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE
             , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id)
             );
@@ -175,27 +178,27 @@ customMigrations = mapF $ \case
         UPDATE "lms_user"
           SET "status_day" = CAST("status"->>'day' AS date)
             , "status" = "status"->'lms-status'
-        ;  
+        ;
       |]
 
   Migration20240212InitInterfaceHealth ->
     unlessM (tableExists "interface_health") $ do -- fill health table with some defaults
       [executeQQ|
         CREATE TABLE "interface_health"
-          ( id BIGSERIAL NOT NULL 
-          , interface CHARACTER VARYING NOT NULL 
-          , subtype   CHARACTER VARYING 
-          , write     BOOLEAN 
-          , hours     BIGINT NOT NULL 
-          , PRIMARY KEY(id) 
-          , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) 
-          ); 
-        INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") 
-        VALUES 
-            ('Printer', 'Acknowledge', True, 168) 
-          , ('AVS'    , 'Synch'      , True , 96) 
-        ON CONFLICT DO NOTHING; 
-      |]    
+          ( id BIGSERIAL NOT NULL
+          , interface CHARACTER VARYING NOT NULL
+          , subtype   CHARACTER VARYING
+          , write     BOOLEAN
+          , hours     BIGINT NOT NULL
+          , PRIMARY KEY(id)
+          , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write)
+          );
+        INSERT INTO "interface_health" ("interface", "subtype", "write", "hours")
+        VALUES
+            ('Printer', 'Acknowledge', True, 168)
+          , ('AVS'    , 'Synch'      , True , 96)
+        ON CONFLICT DO NOTHING;
+      |]
 
   Migration20240224UniquenessCompanyAvsNr ->
     whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade
@@ -204,6 +207,85 @@ customMigrations = mapF $ \case
         ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand";
       |]
 
+  Migration20240930RoomOccurrences -> do
+    whenM (tableColumnExists "tutorial" "room")
+      [executeQQ|
+        WITH updated_scheduled AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_scheduled
+            FROM tutorial AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE tutorial AS t
+        SET "time" = jsonb_set(t."time", '{scheduled}', us.new_scheduled)
+        FROM updated_scheduled AS us
+        WHERE t.id = us.id
+        ;
+        WITH updated_exceptions AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_exceptions
+            FROM tutorial AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE tutorial AS t
+        SET "time" = jsonb_set(t."time", '{exceptions}', ue.new_exceptions)
+        FROM updated_exceptions AS ue
+        WHERE t.id = ue.id
+        ;
+        ALTER TABLE "tutorial" DROP COLUMN "room";
+      |]
+
+    whenM (tableColumnExists "course_event" "room")
+      [executeQQ|
+        WITH updated_scheduled AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_scheduled
+            FROM course_event AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE course_event AS t
+        SET "time" = jsonb_set(t."time", '{scheduled}', us.new_scheduled)
+        FROM updated_scheduled AS us
+        WHERE t.id = us.id
+        ;
+        WITH updated_exceptions AS (
+            SELECT id
+                , jsonb_agg(
+                    CASE
+                        WHEN jsonb_exists(elem, 'room') THEN elem
+                        ELSE jsonb_set(elem, '{room}', to_jsonb(t.room))
+                    END
+                ) AS new_exceptions
+            FROM course_event AS t
+            CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem
+            GROUP BY t.id, t.room
+        )
+        UPDATE course_event AS t
+        SET "time" = jsonb_set(t."time", '{exceptions}', ue.new_exceptions)
+        FROM updated_exceptions AS ue
+        WHERE t.id = ue.id
+        ;
+        ALTER TABLE "course_event" DROP COLUMN "room";
+      |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do
@@ -232,15 +314,22 @@ tableDropEmpty table = whenM (tableExists table) $ do
 columnExists :: MonadIO m
              => Text -- ^ Table
              -> Text -- ^ Column
-             -> ReaderT SqlBackend m Bool -- BEWARE: use tablesExist beforehand!!! 
+             -> ReaderT SqlBackend m Bool -- BEWARE: use tablesExist beforehand!!!
 columnExists table column = do
   haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|]
   case haveColumn :: [Single PersistValue] of
     [_]    -> return True
     _other -> return False
 
+-- | checks table existence before checking column existence to avoid errors
+tableColumnExists :: MonadIO m
+             => Text -- ^ Table
+             -> Text -- ^ Column
+             -> ReaderT SqlBackend m Bool
+tableColumnExists table column = and2M (tableExists table) (columnExists table column)
+
 -- | equivalent to andM [ tableExists, not <$> columnExists]
-columnNotExists :: MonadIO m 
+columnNotExists :: MonadIO m
              => Text -- ^ Table
              -> Text -- ^ Column
              -> ReaderT SqlBackend m Bool
@@ -248,7 +337,7 @@ columnNotExists table column = and2M (tableExists table) (not <$> columnExists t
 
 indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 indexExists ixName = do
-  res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] 
+  res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|]
   return $ case res of
     [Single e]  -> e
     _other      -> True

src/Model/Types/Avs.hs

@@ -280,7 +280,7 @@ discernAvsIds someid = aux someid
 
 
 data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
-  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData)
+  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData, Binary)
 
 instance ToJSON AvsLicence where
     -- toJSON al = Number $ fromEnum AvsLicence -- would do, but...

src/Model/Types/Common.hs

@@ -1,7 +1,9 @@
--- 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@tcs.ifi.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@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 {-|
 Module: Model.Types.Common
 Description: Common types used by most @Model.Types.*@-Modules
@@ -10,12 +12,13 @@ Types used by multiple other @Model.Types.*@-Modules
 -}
 module Model.Types.Common
   ( module Model.Types.Common
+  , module JSON
   ) where
 
 import Import.NoModel
 
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
-
+import Database.Esqueleto.PostgreSQL.JSON as JSON (JSONB(..), JSONAccessor(..), unJSONB)
 
 type Count  = Sum Integer
 type Points = Centi
@@ -68,3 +71,7 @@ type SessionFileReference = Digest SHA3_256
 
 type QualificationName       = CI Text
 type QualificationShorthand  = CI Text
+
+deriving newtype instance NFData    a => NFData    (JSONB a)
+deriving newtype instance Semigroup a => Semigroup (JSONB a)
+deriving newtype instance Monoid    a => Monoid    (JSONB a)

src/Model/Types/DateTime.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -14,6 +14,7 @@ module Model.Types.DateTime
   ) where
 
 import Import.NoModel
+import Model.Types.Room
 
 -- import qualified Data.Set as Set
 import Data.Ratio ((%))
@@ -29,6 +30,7 @@ import Data.Time.Calendar.WeekDate
 -- import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat)
 
 import Database.Persist.Sql
+import Database.Esqueleto.PostgreSQL.JSON (JSONB(..))
 
 import Web.HttpApiData
 
@@ -39,7 +41,7 @@ import Data.Aeson.Types as Aeson
 --  Terms and anything loosely related to time
 
 newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
-    deriving (Show, Read, Eq, Ord, Generic, Enum)     
+    deriving (Show, Read, Eq, Ord, Generic, Enum)
     deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON)
     deriving anyclass (NFData)
     -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData)
@@ -86,23 +88,23 @@ termFromText t
   = Right TermIdentifier {..}
   ---- *  | Just (review shortened -> year) <- readMaybe $ Text.unpack t
   ---- *  = Right TermIdentifier {..}
-  | otherwise 
-  = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." 
-  
-  
+  | otherwise
+  = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number."
+
+
 daysPerYear :: Rational
 daysPerYear = 365 + (97 % 400)
 
-dayOffset :: Rational 
+dayOffset :: Rational
 dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
-  where     
+  where
     dayzero   = toEnum 0
     yearzero  = fst3 $ toGregorian dayzero
-    diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 
-    
+    diffstart = diffDays dayzero $ fromGregorian yearzero 1 1
+
 -- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
-termToRational :: TermIdentifier -> Rational 
-termToRational = fromInteger . year 
+termToRational :: TermIdentifier -> Rational
+termToRational = fromInteger . year
 
 termFromRational :: Rational -> TermIdentifier
 termFromRational = TermIdentifier . floor
@@ -159,15 +161,16 @@ guessDay t TermDayEnd          = pred $ guessDay (succ t) TermDayStart
 guessDay t TermDayLectureEnd   = pred $ pred $ guessDay t TermDayEnd  -- Friday of last calendar week, no lectures on Saturday/Sunday
 
 
-withinTerm :: Day -> TermIdentifier -> Bool 
+withinTerm :: Day -> TermIdentifier -> Bool
 withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
 
 data OccurrenceSchedule = ScheduleWeekly
                           { scheduleDayOfWeek :: WeekDay
                           , scheduleStart     :: TimeOfDay
                           , scheduleEnd       :: TimeOfDay
+                          , scheduleRoom      :: Maybe RoomReference
                           }
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Eq, Ord, Show, Generic,Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions
@@ -181,23 +184,24 @@ data OccurrenceException = ExceptOccur
                           { exceptDay   :: Day
                           , exceptStart :: TimeOfDay
                           , exceptEnd   :: TimeOfDay
+                          , exceptRoom  :: Maybe RoomReference -- ignored in Ord instance
                           }
                         | ExceptNoOccur
                           { exceptTime  :: LocalTime
                           }
-  deriving (Eq, Read, Show, Generic)
+  deriving (Eq, Show, Generic,Binary)
   deriving anyclass (NFData)
 
 -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically
-instance Ord OccurrenceException where 
-  compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be}  
+instance Ord OccurrenceException where
+  compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be}
     = compare (ad,as,ae) (bd,bs,be)
   compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e}
     = replaceEq LT $ compare (LocalTime d s) e
-  compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} 
+  compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s}
     = replaceEq GT $ compare e (LocalTime d s)
   compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be }
-    = compare ae be 
+    = compare ae be
 
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
@@ -217,7 +221,7 @@ data Occurrences = Occurrences
   { occurrencesScheduled  :: Set OccurrenceSchedule
   , occurrencesExceptions :: Set OccurrenceException
   }
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions
@@ -225,24 +229,40 @@ deriveJSON defaultOptions
   } ''Occurrences
 derivePersistFieldJSON ''Occurrences
 
+instance Semigroup Occurrences where
+  (<>) Occurrences{occurrencesScheduled = aSched          , occurrencesExceptions = aExcept}
+       Occurrences{occurrencesScheduled =           bSched, occurrencesExceptions =            bExcept}
+    =  Occurrences{occurrencesScheduled = aSched <> bSched, occurrencesExceptions = aExcept <> bExcept}
+
+instance Monoid Occurrences where
+  mempty = Occurrences mempty mempty
+
+jsonbOCCUR :: Maybe (JSONB Occurrences) -> Occurrences
+jsonbOCCUR = foldMap unJSONB
+
+occurJSONB :: Occurrences -> Maybe (JSONB Occurrences)
+occurJSONB = Just . JSONB
+
+_Occurrences :: Iso' (JSONB Occurrences) Occurrences
+_Occurrences = iso unJSONB JSONB
+
 
 nullaryPathPiece ''DayOfWeek camelToPathPiece
 
-
 -- test :: IO [OccurrenceException]
--- test = do 
+-- test = do
 --   now <- getCurrentTime
 --   tz <- getCurrentTimeZone
---   let lt1 = utcToLocalTime tz now 
---       tomorrow = addUTCTime nominalDay now 
+--   let lt1 = utcToLocalTime tz now
+--       tomorrow = addUTCTime nominalDay now
 --       lt2 = utcToLocalTime tz tomorrow
---       yesterday = addUTCTime (negate nominalDay) now 
+--       yesterday = addUTCTime (negate nominalDay) now
 --       lt3 = utcToLocalTime tz yesterday
---   pure 
---     [ ExceptOccur (utctDay tomorrow ) midday midnight
---     , ExceptOccur (utctDay now      ) midnight midnight
---     , ExceptOccur (utctDay now      ) midday midnight
---     , ExceptOccur (utctDay yesterday) midday midnight 
+--   pure
+--     [ ExceptOccur (utctDay tomorrow ) midday   midnight Nothing
+--     , ExceptOccur (utctDay now      ) midnight midnight Nothing
+--     , ExceptOccur (utctDay now      ) midday   midnight Nothing
+--     , ExceptOccur (utctDay yesterday) midday   midnight Nothing
 --     , ExceptNoOccur lt3
 --     , ExceptNoOccur lt1
 --     , ExceptNoOccur lt2

src/Model/Types/Room.hs

@@ -19,7 +19,7 @@ data RoomReference
     { roomRefLink :: URI
     , roomRefInstructions :: Maybe StoredMarkup
     }
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions

src/Model/Types/User.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,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
 
@@ -15,7 +15,7 @@ data SystemFunction
   = SystemExamOffice
   | SystemFaculty
   | SystemStudent
-  | SystemPrinter  
+  | SystemPrinter
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite, Hashable, NFData)
 
@@ -24,3 +24,42 @@ pathPieceJSON ''SystemFunction
 pathPieceJSONKey ''SystemFunction
 derivePersistFieldPathPiece ''SystemFunction
 pathPieceBinary ''SystemFunction
+
+
+
+--------------------------------------------------------------------------------------
+-- User related dataypes which are not stored in User itself, but in various places
+
+data UserDrivingPermit = UserDrivingPermitB
+                       | UserDrivingPermitB01
+  deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData)
+
+instance Show UserDrivingPermit where
+  show UserDrivingPermitB   = "B"
+  show UserDrivingPermitB01 = "B01"
+
+instance RenderMessage a UserDrivingPermit where
+  renderMessage _foundation _languages = tshow
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 3
+  } ''UserDrivingPermit
+derivePersistFieldJSON ''UserDrivingPermit
+nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3
+
+data UserEyeExam = UserEyeExamSX
+                 | UserEyeExamS01
+  deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData)
+
+instance Show UserEyeExam where
+  show UserEyeExamSX  = "SX"
+  show UserEyeExamS01 = "S01"
+
+instance RenderMessage a UserEyeExam where
+  renderMessage _foundation _languages = tshow
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 3
+  } ''UserEyeExam
+derivePersistFieldJSON ''UserEyeExam
+nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3

src/Network/URI/Instances.hs

@@ -18,6 +18,7 @@ import Data.Swagger
 import Data.Swagger.Internal.Schema
 
 import Data.Proxy
+import Data.Binary
 
 import Servant.Docs
 
@@ -28,6 +29,8 @@ import Control.Monad.Fail (MonadFail(..))
 import Database.Persist
 import Database.Persist.Sql
 
+deriving instance Binary URIAuth
+deriving instance Binary URI
 
 instance ToHttpApiData URI where
   toQueryParam = pack . ($ mempty) . uriToString id
@@ -54,7 +57,7 @@ instance Aeson.FromJSON URI where
   parseJSON = Aeson.withText "URI" $ maybe (fail "Could not parse URI") return . parseURIReference . unpack
 
 instance PersistField URI where
-  toPersistValue = PersistText . pack . ($ mempty) . uriToString id 
+  toPersistValue = PersistText . pack . ($ mempty) . uriToString id
   fromPersistValue (PersistText t) = maybe (Left "Could not parse URI") return . parseURIReference $ unpack t
   fromPersistValue v = Left $ "Failed to parse Haskell type `URI`; expected text from database but received: " <> tshow v <> "."
 instance PersistFieldSql URI where

src/Settings.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,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
 
@@ -207,7 +207,6 @@ data AppSettings = AppSettings
 
     , appMemcachedConf          :: Maybe MemcachedConf
     , appMemcacheAuth           :: Bool
-    , appMemcachedLocalConf     :: Maybe (ARCConf Int)
 
     , appUploadCacheConf        :: Maybe Minio.ConnectInfo
     , appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket
@@ -239,9 +238,6 @@ data AppSettings = AppSettings
     , appJobLmsQualificationsEnqueueHour :: Maybe Natural
     , appJobLmsQualificationsDequeueHour :: Maybe Natural
 
-    , appFileSourceARCConf      :: Maybe (ARCConf Int)
-    , appFileSourcePrewarmConf  :: Maybe PrewarmCacheConf
-
     , appBotMitigations         :: Set SettingBotMitigation
 
     , appVolatileClusterSettingsCacheTime :: DiffTime
@@ -421,18 +417,6 @@ data VerpMode = VerpNone
               | Verp { verpPrefix :: Text, verpSeparator :: Char }
   deriving (Eq, Show, Read, Generic)
 
-data ARCConf w = ARCConf
-  { arccMaximumGhost :: Int
-  , arccMaximumWeight :: w
-  } deriving (Eq, Ord, Read, Show, Generic)
-
-data PrewarmCacheConf = PrewarmCacheConf
-  { precMaximumWeight :: Int
-  , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
-  , precSteps :: Natural
-  , precMaxSpeedup :: Rational
-  } deriving (Eq, Ord, Read, Show, Generic)
-
 data SettingBotMitigation
   = SettingBotMitigationOnlyLoggedInTableSorting
   | SettingBotMitigationUnauthorizedFormHoneypots
@@ -476,16 +460,6 @@ deriveJSON defaultOptions
   , constructorTagModifier = camelToPathPiece' 1
   } ''JobMode
 
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''ARCConf
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''PrewarmCacheConf
-
-makeLenses_ ''PrewarmCacheConf
-
 nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3
 pathPieceJSON ''SettingBotMitigation
 pathPieceJSONKey ''SettingBotMitigation
@@ -688,7 +662,6 @@ instance FromJSON AppSettings where
 
         appMemcachedConf          <- assertM validMemcachedConf <$> o .:? "memcached"
         appMemcacheAuth           <- o .:? "memcache-auth" .!= False
-        appMemcachedLocalConf     <- assertM isValidARCConf <$> o .:? "memcached-local"
 
         appMailFrom               <- o .: "mail-from"
         appMailEnvelopeFrom       <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
@@ -825,17 +798,6 @@ instance FromJSON AppSettings where
         appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour"
         appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour"
 
-        appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc"
-
-        let isValidPrewarmConf PrewarmCacheConf{..} = and
-              [ precMaximumWeight > 0
-              , precStart >= 0
-              , precEnd >= 0, precEnd <= precStart
-              , precSteps > 0
-              , precMaxSpeedup >= 1
-              ]
-        appFileSourcePrewarmConf <- over (_Just . _precInhibit) (max 0) . assertM isValidPrewarmConf <$> o .:? "file-source-prewarm"
-
         appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty
 
         appVolatileClusterSettingsCacheTime <- o .: "volatile-cluster-settings-cache-time"
@@ -848,7 +810,6 @@ instance FromJSON AppSettings where
         appLegalExternal <- o .: "legal-external"
 
         return AppSettings{..}
-      where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
 
 makeClassy_ ''AppSettings
 
@@ -896,10 +857,12 @@ widgetFile
 -- hamletFile' :: FilePath -> Q Exp
 -- hamletFile' nameBase = hamletFile $ "templates" </> nameBase
 
-
--- | Raw bytes at compile time of @config/settings.yml@
+-- | Raw bytes at compile time of @config/settings.yml@ (and also @config/develop-setting.yml for development builds)
 configSettingsYmlBS :: ByteString
 configSettingsYmlBS = $(embedFile configSettingsYml)
+#ifdef DEVELOPMENT
+                   <> $(embedFile "config/develop-settings.yml")
+#endif
 
 -- | @config/settings.yml@, parsed to a @Value@.
 configSettingsYmlValue :: Value

src/Utils.hs

@@ -44,8 +44,6 @@ import Utils.I18n as Utils
 import Utils.NTop as Utils
 import Utils.HttpConditional as Utils
 import Utils.Persist as Utils
-import Utils.ARC as Utils
-import Utils.LRU as Utils
 import Utils.Set as Utils
 
 import Text.Blaze (Markup, ToMarkup(..))
@@ -655,7 +653,7 @@ guardMonoid True  x = x
 assertMonoid :: Monoid m => (m -> Bool) -> m -> m
 assertMonoid f x = guardMonoid (f x) x
 
--- fold would also do, but is more risky if the Folable isn't Maybe
+-- fold would also do, but is more risky if the Foldable isn't Maybe
 maybeMonoid :: Monoid m => Maybe m -> m
 -- ^ Identify `Nothing` with `mempty`
 maybeMonoid = fromMaybe mempty
@@ -924,7 +922,14 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
--- | change second of maybe pair to Nothing, if both are Just and equal
+infix 4 ==~
+
+-- | Equality treating `Nothing` as an always matching wildcard
+(==~) :: Eq a => Maybe a -> Maybe a -> Bool
+(==~) (Just x) (Just y) = x == y
+(==~) _        _        = True
+
+-- | change second of maybe pair to `Nothing`, if both are `Just` and equal
 eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a)
 eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing)
 eq2nothing p = p
@@ -946,6 +951,7 @@ deepAlt altFst         Nothing = altFst
 deepAlt (Just Nothing) altSnd  = altSnd
 deepAlt altFst         _       = altFst
 
+-- | flipped `foldMap` with type restriction to Maybe, also see @maybeMonoid@
 maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
 maybeEmpty = flip foldMap
 
@@ -1184,6 +1190,17 @@ maybeCatchAll act = catch act ignore
     ignore :: Monad m => SomeException -> m (Maybe a)
     ignore _ = return Nothing
 
+-- | Ignore all errors by returning a monadic default value.
+catchAllDefault :: MonadCatch m => m a -> m (Maybe a) -> m a
+catchAllDefault dft = fromMaybeM dft .  maybeCatchAll
+
+-- | Ignore all errors by returning mempty. (Not sure if this function is a good idea)
+catchAllMonoid :: (MonadCatch m, Monoid a) => m a -> m a
+catchAllMonoid act = catch act ignore
+  where
+    ignore :: (Monad m, Monoid a) => SomeException -> m a
+    ignore _ = pure mempty
+
 maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
 maybeExceptT err act = lift act >>= maybe (throwE err) return
 

src/Utils/ARC.hs

@@ -1,344 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# LANGUAGE BangPatterns #-}
-
-module Utils.ARC
-  ( ARCTick
-  , ARC, initARC
-  , arcAlterF, lookupARC, insertARC
-  , ARCHandle, initARCHandle, cachedARC, cachedARC'
-  , lookupARCHandle
-  , readARCHandle
-  , arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize
-  , getARCRecentWeight, getARCFrequentWeight
-  , describeARC
-  , NFDynamic(..), _NFDynamic, DynARC, DynARCHandle
-  ) where
-
-import ClassyPrelude
-
-import Data.HashPSQ (HashPSQ)
-import qualified Data.HashPSQ as HashPSQ
-
-import Control.Lens
-
-import Type.Reflection
-import Text.Show (showString, shows)
-
-import Data.Hashable (Hashed, hashed)
-
--- https://web.archive.org/web/20210115184012/https://dbs.uni-leipzig.de/file/ARC.pdf
--- https://jaspervdj.be/posts/2015-02-24-lru-cache.html
-
-
-data NFDynamic where
-  NFDynamic :: forall a. NFData a => TypeRep a -> a -> NFDynamic
-
-_NFDynamic :: forall a. (Typeable a, NFData a) => Prism' NFDynamic a
-_NFDynamic = prism' toNFDyn fromNFDynamic
-  where
-    toNFDyn v = NFDynamic typeRep v
-    fromNFDynamic (NFDynamic t v)
-      | Just HRefl <- t `eqTypeRep` rep = Just v
-      | otherwise                       = Nothing
-      where rep = typeRep :: TypeRep a
-
-instance NFData NFDynamic where
-  rnf (NFDynamic t v) = rnfTypeRep t `seq` rnf v
-
-instance Show NFDynamic where
-  showsPrec _ (NFDynamic t _) = showString "<<" . shows t . showString ">>"
-
-
-newtype ARCTick = ARCTick { _getARCTick :: Word64 }
-  deriving (Eq, Ord, Show)
-  deriving newtype (NFData)
-
-makeLenses ''ARCTick
-
-data ARC k w v = ARC
-  { arcRecent, arcFrequent :: !(HashPSQ (Hashed k) ARCTick (v, w))
-  , arcGhostRecent, arcGhostFrequent :: !(HashPSQ (Hashed k) ARCTick ())
-  , arcRecentWeight, arcFrequentWeight :: !w
-  , arcTargetRecent, arcMaximumWeight :: !w
-  , arcMaximumGhost :: !Int
-  }
-
-type DynARC k w = ARC (SomeTypeRep, k) w NFDynamic
-
-instance (NFData k, NFData w, NFData v) => NFData (ARC k w v) where
-  rnf ARC{..} = rnf arcRecent
-          `seq` rnf arcFrequent
-          `seq` rnf arcGhostRecent
-          `seq` rnf arcGhostFrequent
-          `seq` rnf arcRecentWeight
-          `seq` rnf arcFrequentWeight
-          `seq` rnf arcTargetRecent
-          `seq` rnf arcMaximumWeight
-          `seq` rnf arcMaximumGhost
-
-describeARC :: Show w
-            => ARC k w v
-            -> String
-describeARC ARC{..} = intercalate ", "
-  [ "arcRecent: "         <> show (HashPSQ.size arcRecent)
-  , "arcFrequent: "       <> show (HashPSQ.size arcFrequent)
-  , "arcGhostRecent: "    <> show (HashPSQ.size arcGhostRecent)
-  , "arcGhostFrequent: "  <> show (HashPSQ.size arcGhostFrequent)
-  , "arcRecentWeight: "   <> show arcRecentWeight
-  , "arcFrequentWeight: " <> show arcFrequentWeight
-  , "arcTargetRecent: "   <> show arcTargetRecent
-  , "arcMaximumWeight: "  <> show arcMaximumWeight
-  , "arcMaximumGhost: "   <> show arcMaximumGhost
-  ]
-
-arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize :: ARC k w v -> Int
-arcRecentSize = HashPSQ.size . arcRecent
-arcFrequentSize = HashPSQ.size . arcFrequent
-arcGhostRecentSize = HashPSQ.size . arcGhostRecent
-arcGhostFrequentSize = HashPSQ.size . arcGhostFrequent
-
-getARCRecentWeight, getARCFrequentWeight :: ARC k w v -> w
-getARCRecentWeight = arcRecentWeight
-getARCFrequentWeight = arcFrequentWeight
-
-initialARCTick :: ARCTick
-initialARCTick = ARCTick 0
-
-initARC :: forall k w v.
-           Integral w
-        => Int -- ^ @arcMaximumGhost@
-        -> w -- ^ @arcMaximumWeight@
-        -> (ARC k w v, ARCTick)
-initARC arcMaximumGhost arcMaximumWeight
-  | arcMaximumWeight < 0 = error "initARC given negative maximum weight"
-  | arcMaximumGhost < 0 = error "initARC given negative maximum ghost size"
-  | otherwise = (, initialARCTick) ARC
-    { arcRecent = HashPSQ.empty
-    , arcFrequent = HashPSQ.empty
-    , arcGhostRecent = HashPSQ.empty
-    , arcGhostFrequent = HashPSQ.empty
-    , arcRecentWeight = 0
-    , arcFrequentWeight = 0
-    , arcMaximumWeight
-    , arcTargetRecent = 0
-    , arcMaximumGhost
-    }
-
-
-infixl 6 |-
-(|-) :: (Num a, Ord a) => a -> a -> a
-(|-) m s
-  | s >= m = 0
-  | otherwise = m - s
-
-  
-arcAlterF :: forall f k w v.
-             ( Ord k, Hashable k
-             , Functor f
-             , Integral w
-             , NFData k, NFData w, NFData v
-             )
-          => k
-          -> (Maybe (v, w) -> f (Maybe (v, w)))
-          -> ARC k w v
-          -> ARCTick -> f (ARC k w v, ARCTick)
--- | Unchecked precondition: item weights are always less than `arcMaximumWeight`
-arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now
-  | later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight
-  | otherwise = (, later) <$> if
-    | Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent
-      -> f (Just x) <&> \case
-           Nothing -> oldARC
-             { arcFrequent = arcFrequent'
-             , arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent
-             , arcFrequentWeight = arcFrequentWeight - w
-             }
-           Just !(force -> x'@(_, w'))
-             -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent
-                 in oldARC
-                      { arcFrequent = HashPSQ.insert k now x' arcFrequent''
-                      , arcFrequentWeight = arcFrequentWeight'' + w'
-                      , arcGhostFrequent = arcGhostFrequent'
-                      }
-    | Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent
-      -> f (Just x) <&> \case
-           Nothing -> oldARC
-             { arcRecent = arcRecent'
-             , arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
-             , arcRecentWeight = arcRecentWeight - w
-             }
-           Just !(force -> x'@(_, w'))
-             -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent
-                 in oldARC
-                      { arcRecent = arcRecent'
-                      , arcRecentWeight = arcRecentWeight - w
-                      , arcFrequent = HashPSQ.insert k now x' arcFrequent'
-                      , arcFrequentWeight = arcFrequentWeight' + w'
-                      , arcGhostFrequent = arcGhostFrequent'
-                      }
-    | Just (_p, (), arcGhostRecent') <- HashPSQ.deleteView k arcGhostRecent
-      -> f Nothing <&> \case
-           Nothing -> oldARC
-             { arcGhostRecent = HashPSQ.insert k now () arcGhostRecent'
-             }
-           Just !(force -> x@(_, w))
-             -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight)
-                    (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent
-                    (arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent'
-                 in oldARC
-                      { arcRecent = arcRecent'
-                      , arcFrequent = HashPSQ.insert k now x arcFrequent'
-                      , arcGhostRecent = arcGhostRecent''
-                      , arcGhostFrequent = arcGhostFrequent'
-                      , arcRecentWeight = arcRecentWeight'
-                      , arcFrequentWeight = arcFrequentWeight' + w
-                      , arcTargetRecent = arcTargetRecent'
-                      }
-    | Just (_p, (), arcGhostFrequent') <- HashPSQ.deleteView k arcGhostFrequent
-      -> f Nothing <&> \case
-           Nothing -> oldARC
-             { arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent'
-             }
-           Just !(force -> x@(_, w))
-             -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight)
-                    (arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent'
-                    (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent
-                 in oldARC
-                      { arcRecent = arcRecent'
-                      , arcFrequent = HashPSQ.insert k now x arcFrequent'
-                      , arcGhostRecent = arcGhostRecent'
-                      , arcGhostFrequent = arcGhostFrequent''
-                      , arcRecentWeight = arcRecentWeight'
-                      , arcFrequentWeight = arcFrequentWeight' + w
-                      , arcTargetRecent = arcTargetRecent'
-                      }
-    | otherwise -> f Nothing <&> \case
-        Nothing -> oldARC
-          { arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
-          }
-        Just !(force -> x@(_, w))
-          -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent
-              in oldARC
-                   { arcRecent = HashPSQ.insert k now x arcRecent'
-                   , arcRecentWeight = arcRecentWeight' + w
-                   , arcGhostRecent = arcGhostRecent'
-                   }
-  where
-    avgWeight = round $ toRational (arcRecentWeight + arcFrequentWeight) / toRational (HashPSQ.size arcFrequent + HashPSQ.size arcRecent)
-    
-    later :: ARCTick
-    later = over getARCTick succ now
-    
-    evictToSize :: w -> HashPSQ (Hashed k) ARCTick (v, w) -> w -> HashPSQ (Hashed k) ARCTick () -> (HashPSQ (Hashed k) ARCTick (v, w), w, HashPSQ (Hashed k) ARCTick ())
-    evictToSize tSize c cSize ghostC
-      | cSize <= tSize = (c, cSize, ghostC)
-      | Just (k', p', (_, w'), c') <- HashPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ HashPSQ.insert k' p' () ghostC
-      | otherwise = error "evictToSize: cannot reach required size through eviction"
-
-    evictGhostToCount :: HashPSQ (Hashed k) ARCTick () -> HashPSQ (Hashed k) ARCTick ()
-    evictGhostToCount c
-      | HashPSQ.size c <= arcMaximumGhost = c
-      | Just (_, _, _, c') <- HashPSQ.minView c = evictGhostToCount c'
-      | otherwise = error "evictGhostToCount: cannot reach required count through eviction"
-
-lookupARC :: forall k w v.
-             ( Ord k, Hashable k
-             , Integral w
-             , NFData k, NFData w, NFData v
-             )
-          => k
-          -> (ARC k w v, ARCTick)
-          -> Maybe (v, w)
-lookupARC k = getConst . uncurry (arcAlterF k Const)
-
-insertARC :: forall k w v.
-             ( Ord k, Hashable k
-             , Integral w
-             , NFData k, NFData w, NFData v
-             )
-          => k
-          -> Maybe (v, w)
-          -> ARC k w v
-          -> ARCTick -> (ARC k w v, ARCTick)
-insertARC k newVal = (runIdentity .) . arcAlterF k (const $ pure newVal)
-
-
-newtype ARCHandle k w v = ARCHandle { _getARCHandle :: IORef (ARC k w v, ARCTick) }
-  deriving (Eq)
-
-type DynARCHandle k w = ARCHandle (SomeTypeRep, k) w NFDynamic
-
-initARCHandle :: forall k w v m.
-                 ( MonadIO m
-                 , Integral w
-                 )
-              => Int -- ^ @arcMaximumGhost@
-              -> w -- ^ @arcMaximumWeight@
-              -> m (ARCHandle k w v)
-initARCHandle maxGhost maxWeight = fmap ARCHandle . newIORef $ initARC maxGhost maxWeight
-
-cachedARC' :: forall k w v m.
-              ( MonadIO m
-              , Ord k, Hashable k
-              , Integral w
-              , NFData k, NFData w, NFData v
-              )
-           => ARCHandle k w v
-           -> k
-           -> (Maybe (v, w) -> m (Maybe (v, w)))
-           -> m (Maybe v)
-cachedARC' (ARCHandle arcVar) k f = do
-  oldVal <- lookupARC k <$> readIORef arcVar
-  newVal <- f oldVal
-  atomicModifyIORef' arcVar $ (, ()) . uncurry (insertARC k newVal)
-  -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
-  -- well drop newer values computed during the update.
-  --
-  -- This was deemed unacceptable due to the risk of cache
-  -- invalidations being silently dropped
-  --
-  -- Another alternative would be to use "optimistic locking",
-  -- i.e. read the current value of `arcVar`, compute an updated
-  -- version, and write it back atomically iff the `ARCTick` hasn't
-  -- changed.
-  --
-  -- This was not implemented in the hopes that atomicModifyIORef'
-  -- already offers sufficient performance.
-  --
-  -- If optimistic locking is implemented there is a risk of
-  -- performance issues due to the overhead and contention likely
-  -- associated with the atomic transaction required for the "compare
-  -- and swap"
-  return $ view _1 <$> newVal
-
-cachedARC :: forall k w v m.
-             ( MonadIO m
-             , Ord k, Hashable k
-             , Integral w
-             , NFData k, NFData w, NFData v
-             )
-          => ARCHandle k w v
-          -> k
-          -> (Maybe (v, w) -> m (v, w))
-          -> m v
-cachedARC h k f = fromMaybe (error "cachedARC: cachedARC' returned Nothing") <$> cachedARC' h k (fmap Just . f)
-  
-lookupARCHandle :: forall k w v m.
-                   ( MonadIO m
-                   , Ord k, Hashable k
-                   , Integral w
-                   , NFData k, NFData w, NFData v
-                   )
-                => ARCHandle k w v
-                -> k
-                -> m (Maybe (v, w))
-lookupARCHandle (ARCHandle arcVar) k = lookupARC k <$> readIORef arcVar
-
-
-readARCHandle :: MonadIO m
-              => ARCHandle k w v
-              -> m (ARC k w v, ARCTick)
-readARCHandle (ARCHandle arcVar) = readIORef arcVar

src/Utils/Avs.hs

@@ -86,7 +86,7 @@ mkAvsQuery _ _ _ = AvsQuery
     fakePerson :: AvsQueryPerson -> AvsResponsePerson
     fakePerson =
       let
-        sarah    = Set.singleton $ AvsDataPerson "Sarah"   "Vaupel"  Nothing            2 (AvsPersonId        2) mempty
+        sarah    = Set.singleton $ AvsDataPerson "Sarah"   "Vaupel"  Nothing            2 (AvsPersonId        2) $ Set.singleton $ AvsDataPersonCard True Nothing Nothing AvsCardColorRot mempty Nothing Nothing Nothing Nothing (AvsCardNo "424242") "8"
         stephan  = Set.singleton $ AvsDataPerson "Stephan" "Barth"   Nothing            4 (AvsPersonId        4) mempty
         steffen  = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
         sumpfi1  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty

src/Utils/DateTime.hs

@@ -16,8 +16,8 @@ module Utils.DateTime
   , mkDateTimeFormatter
   , nominalHour, nominalMinute
   , minNominalYear, avgNominalYear
-  , diffMinute, diffHour, diffDay
-  , module Zones  
+  , diffSecond, diffMinute, diffHour, diffDay
+  , module Zones
   , day
   , utctDayMidnight
   ) where
@@ -86,7 +86,7 @@ timeLocaleMap extra@((_, defLocale):_) = do
   letE [localeMap'] (varE localeMap)
 
 compileTime :: ExpQ -- Type UTCTime
-compileTime = do 
+compileTime = do
   now <- runIO getCurrentTime
   [e|now|]
 
@@ -166,7 +166,8 @@ avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
 -- DiffTime --
 --------------
 
-diffMinute, diffHour, diffDay :: DiffTime
+diffSecond, diffMinute, diffHour, diffDay :: DiffTime
+diffSecond = 1
 diffMinute = 60
 diffHour = 3600
 diffDay = 86400

src/Utils/Files.hs

@@ -48,6 +48,7 @@ import System.IO.Unsafe
 
 import Data.Typeable (eqT)
 
+{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-}
 
 sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX)
            => Bool -- ^ Replace? Use only in serializable transaction
@@ -63,9 +64,9 @@ sinkFileDB doReplace fileContentContent = do
         observeSunkChunk StorageDB $ olength fileContentChunkContent
 
         tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. }
-  
+
         existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash]
-      
+
         let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased]
         if | existsChunk -> lift   setContentBased
            | otherwise   -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $
@@ -98,7 +99,7 @@ sinkFileDB doReplace fileContentContent = do
      | otherwise -> do
          deleteWhere [ FileContentEntryHash ==. fileContentHash ]
          insertEntries
-    
+
 
   return fileContentHash
   where fileContentChunkContentBased = True
@@ -163,18 +164,18 @@ sinkMinio content = do
           , Minio.dstObject = dstName
           }
     uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions
-    unless uploadExists $ 
+    unless uploadExists $
       Minio.copyObject copyDst copySrc
     release removeObject
     return $ _sinkMinioRet # contentHash
-  
+
 sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
               => ConduitT () ByteString m ()
               -> MaybeT m FileContentReference
 -- ^ Cannot deal with zero length uploads
 sinkFileMinio = sinkMinio @FileContentReference
 
-  
+
 sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) ()
 sinkFiles = C.mapM sinkFile
 

src/Utils/Form.hs

@@ -903,6 +903,7 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
 isoField :: Functor m => AnIso' a b -> Field m a -> Field m b
 isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso)
 
+-- | Also see non-monadic `Yesod.Form.Functions.convertField`
 convertFieldM :: forall m a b. Monad m => (a -> m b) -> (b -> a) -> Field m a -> Field m b
 convertFieldM = checkMMap . ((fmap Right .) :: (a -> m b) -> (a -> m (Either (SomeMessage (HandlerSite m)) b)))
 

src/Utils/LRU.hs

@@ -1,217 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Utils.LRU
-  ( LRUTick
-  , LRU, initLRU
-  , insertLRU, lookupLRU, touchLRU, timeoutLRU
-  , LRUHandle, initLRUHandle
-  , insertLRUHandle, lookupLRUHandle, touchLRUHandle, timeoutLRUHandle
-  , readLRUHandle
-  , lruStoreSize
-  , getLRUWeight
-  , describeLRU
-  ) where
-
-import ClassyPrelude
-
-import Data.OrdPSQ (OrdPSQ)
-import qualified Data.OrdPSQ as OrdPSQ
-
-import Control.Lens
-
--- https://jaspervdj.be/posts/2015-02-24-lru-cache.html
-
-
-newtype LRUTick = LRUTick { _getLRUTick :: Word64 }
-  deriving (Eq, Ord, Show)
-  deriving newtype (NFData)
-
-makeLenses ''LRUTick
-
-data LRU k t w v = LRU
-  { lruStore :: !(OrdPSQ k (t, LRUTick) (v, w))
-  , lruWeight :: !w
-  , lruMaximumWeight :: !w
-  }
-
-instance (NFData k, NFData t, NFData w, NFData v) => NFData (LRU k t w v) where
-  rnf LRU{..} = rnf lruStore
-          `seq` rnf lruWeight
-          `seq` rnf lruMaximumWeight
-
-describeLRU :: Show w
-            => LRU k t w v
-            -> String
-describeLRU LRU{..} = intercalate ", "
-  [ "lruStore: "         <> show (OrdPSQ.size lruStore)
-  , "lruWeight: "        <> show lruWeight
-  , "lruMaximumWeight: " <> show lruMaximumWeight
-  ]
-
-lruStoreSize :: LRU k t w v -> Int
-lruStoreSize = OrdPSQ.size . lruStore
-
-getLRUWeight :: LRU k t w v -> w
-getLRUWeight = lruWeight
-
-initialLRUTick, maximumLRUTick :: LRUTick
-initialLRUTick = LRUTick 0
-maximumLRUTick = LRUTick maxBound
-
-initLRU :: forall k t w v.
-           Integral w
-        => w -- ^ @lruMaximumWeight@
-        -> (LRU k t w v, LRUTick)
-initLRU lruMaximumWeight
-  | lruMaximumWeight < 0 = error "initLRU given negative maximum weight"
-  | otherwise = (, initialLRUTick) LRU
-    { lruStore = OrdPSQ.empty
-    , lruWeight = 0
-    , lruMaximumWeight
-    }
-
-insertLRU :: forall k t w v.
-             ( Ord k, Ord t
-             , Integral w
-             )
-          => k
-          -> t
-          -> Maybe (v, w)
-          -> LRU k t w v
-          -> LRUTick -> (LRU k t w v, LRUTick)
-insertLRU k t newVal oldLRU@LRU{..} now
-  | later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight
-  | Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now)
-  | Just (_, w) <- newVal = (, later) $ 
-      let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight
-          (fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'')
-            = OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore'
-       in oldLRU
-            { lruStore = lruStore''
-            , lruWeight = lruWeight' - oldWeight + w
-            }
-  | Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = (, now) oldLRU
-      { lruStore = lruStore'
-      , lruWeight = lruWeight - w
-      }
-  | otherwise = (oldLRU, now)
-  where
-    later :: LRUTick
-    later = over getLRUTick succ now
-
-    evictToSize :: w -> OrdPSQ k (t, LRUTick) (v, w) -> w -> (OrdPSQ k (t, LRUTick) (v, w), w)
-    evictToSize tSize c cSize
-      | cSize <= tSize = (c, cSize)
-      | Just (_, _, (_, w'), c') <- OrdPSQ.minView c = evictToSize tSize c' (cSize - w')
-      | otherwise = error "evictToSize: cannot reach required size through eviction"
-
-lookupLRU :: forall k t w v.
-             Ord k
-          => k
-          -> LRU k t w v
-          -> Maybe (v, w)
-lookupLRU k LRU{..} = view _2 <$> OrdPSQ.lookup k lruStore
-
-touchLRU :: forall k t w v.
-            ( Ord k, Ord t
-            , Integral w
-            )
-         => k
-         -> t
-         -> LRU k t w v
-         -> LRUTick -> ((LRU k t w v, LRUTick), Maybe (v, w))
-touchLRU k t oldLRU@LRU{..} now
-  | (Just (_, v), _) <- altered
-  , later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight
-  | (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v)
-  | otherwise = ((oldLRU, now), Nothing)
-  where 
-    altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore
-    
-    later :: LRUTick
-    later = over getLRUTick succ now
-
-timeoutLRU :: forall k t w v.
-              ( Ord k, Ord t
-              , Integral w
-              )
-           => t
-           -> LRU k t w v
-           -> LRU k t w v
-timeoutLRU t oldLRU@LRU{..} = oldLRU
-  { lruStore = lruStore'
-  , lruWeight = lruWeight - evictedWeight
-  }
-  where
-    (evicted, lruStore') = OrdPSQ.atMostView (t, maximumLRUTick) lruStore
-    evictedWeight = sumOf (folded . _3 . _2) evicted
-
-newtype LRUHandle k t w v = LRUHandle { _getLRUHandle :: IORef (LRU k t w v, LRUTick) }
-  deriving (Eq)
-
-initLRUHandle :: forall k t w v m.
-                 ( MonadIO m
-                 , Integral w
-                 )
-              => w -- ^ @lruMaximumWeight@
-              -> m (LRUHandle k t w v)
-initLRUHandle maxWeight = fmap LRUHandle . newIORef $ initLRU maxWeight
-
-insertLRUHandle :: forall k t w v m.
-                   ( MonadIO m
-                   , Ord k, Ord t
-                   , Integral w
-                   , NFData k, NFData t, NFData w, NFData v
-                   )
-                => LRUHandle k t w v
-                -> k
-                -> t
-                -> (v, w)
-                -> m ()
-insertLRUHandle (LRUHandle lruVar) k t newVal
-  = modifyIORef' lruVar $ force . uncurry (insertLRU k t $ Just newVal)
-
-lookupLRUHandle :: forall k t w v m.
-                   ( MonadIO m
-                   , Ord k
-                   )
-                => LRUHandle k t w v
-                -> k
-                -> m (Maybe (v, w))
-lookupLRUHandle (LRUHandle lruVar) k
-  = views _1 (lookupLRU k) <$> readIORef lruVar
-
-touchLRUHandle :: forall k t w v m.
-                  ( MonadIO m
-                  , Ord k, Ord t
-                  , Integral w
-                  , NFData k, NFData t, NFData w, NFData v
-                  )
-               => LRUHandle k t w v
-               -> k
-               -> t
-               -> m (Maybe (v, w))
-touchLRUHandle (LRUHandle lruVar) k t = do
-  oldLRU <- readIORef lruVar
-  let (newLRU, touched) = uncurry (touchLRU k t) oldLRU
-  force newLRU `seq` writeIORef lruVar newLRU
-  return touched
-
-timeoutLRUHandle :: forall k t w v m.
-                    ( MonadIO m
-                    , Ord k, Ord t
-                    , Integral w
-                    , NFData k, NFData t, NFData w, NFData v
-                    )
-                 => LRUHandle k t w v
-                 -> t
-                 -> m ()
-timeoutLRUHandle (LRUHandle lruVar) t
-  = modifyIORef' lruVar $ force . over _1 (timeoutLRU t)
-
-readLRUHandle :: MonadIO m
-              => LRUHandle k t w v
-              -> m (LRU k t w v, LRUTick)
-readLRUHandle (LRUHandle lruVar) = readIORef lruVar