diff --git a/ChangeLog.md b/ChangeLog.md index 8fe2401e2..c50e244b7 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 04.05.2019 + + Kursmaterial + * Version 29.04.2019 Tutorien diff --git a/config/settings.yml b/config/settings.yml index 287baf0b3..974b2e7e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,6 +30,9 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: 52428800 +health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller +health-check-http: "_env:HEALTHCHECK_HTTP:true" +health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 9079b16da..19941107c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -24,6 +24,7 @@ RegisteredSince date@Text: Angemeldet seit #{date} RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis +RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" GenericKey: Schlüssel GenericShort: Kürzel @@ -147,8 +148,8 @@ SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren -SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. -SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. +SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wurde gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh} SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}! @@ -171,7 +172,7 @@ SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe SheetVisibleFrom: Sichtbar für Teilnehmer ab -SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Fristen/Bewertung sich noch ändern kann +SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können SheetActiveFrom: Beginn Abgabezeitraum SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich SheetActiveTo: Ende Abgabezeitraum @@ -213,6 +214,29 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} CorrectorAssignTitle: Korrektor zuweisen +MaterialName: Name +MaterialType: Art +MaterialTypePlaceholder: Folien, Code, Beispiel, ... +MaterialTypeSlides: Folien +MaterialTypeCode: Code +MaterialTypeExample: Beispiel +MaterialDescription: Beschreibung +MaterialVisibleFrom: Sichtbar für Teilnehmer ab +MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren +MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar! +MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}! +MaterialFiles: Dateien +MaterialHeading materialName@MaterialName: Material "#{materialName}" +MaterialListHeading: Materialien +MaterialNewHeading: Neues Material veröffentlichen +MaterialNewTitle: Neues Material +MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren +MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren +MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{display tid}-#{display ssh}-#{csh} +MaterialDeleteQuestion: Wollen Sie das unten aufgeführte Material wirklich löschen? +MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht + Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) @@ -236,6 +260,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. @@ -278,7 +303,7 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium -RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} nach Filter +RowCount count@Int64: #{display count} #{pluralDE count "passender Eintrag" "passende Einträge"} insgesamt DeleteRow: Entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorUpdated: Korrektor erfolgreich aktualisiert @@ -381,6 +406,8 @@ Pseudonyms: Pseudonyme FileTitle: Dateiname FileModified: Letzte Änderung +VisibleFrom: Veröffentlicht +AccessibleSince: Verfügbar seit Corrected: Korrigiert @@ -454,6 +481,7 @@ LDAPLoginTitle: Campus-Login PWHashLoginTitle: Uni2work-Login PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an! DummyLoginTitle: Development-Login +LoginNecessary: Bitte melden Sie sich dazu vorher an! CorrectorNormal: Normal CorrectorMissing: Abwesend @@ -591,6 +619,7 @@ SheetGroupNoGroups: Keine Gruppenabgabe SheetGroupMaxGroupsize: Maximale Gruppengröße SheetFiles: Übungsblatt-Dateien +SheetFileTypeHeader: Zugehörigkeit NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert @@ -702,6 +731,8 @@ MenuInformation: Informationen MenuImpressum: Impressum MenuDataProt: Datenschutz MenuVersion: Versionsgeschichte +MenuInstance: Instanz-Identifikation +MenuHealth: Instanz-Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin: Login @@ -725,6 +756,10 @@ MenuCorrections: Korrekturen MenuCorrectionsOwn: Meine Korrekturen MenuSubmissions: Abgaben MenuSheetList: Übungsblätter +MenuMaterialList: Material +MenuMaterialNew: Neues Material veröffentlichen +MenuMaterialEdit: Material bearbeiten +MenuMaterialDelete: Material löschen MenuTutorialList: Tutorien MenuTutorialNew: Neues Tutorium anlegen MenuSheetNew: Neues Übungsblatt anlegen @@ -892,3 +927,15 @@ TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. + +HealthReport: Instanz-Zustand +InstanceIdentification: Instanz-Identifikation + +InstanceId: Instanz-Nummer +ClusterId: Cluster-Nummer + +HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können +HealthSMTPConnect: SMTP-Server kann erreicht werden +HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus diff --git a/models/materials b/models/materials new file mode 100644 index 000000000..062ab3232 --- /dev/null +++ b/models/materials @@ -0,0 +1,12 @@ +Material -- course material for disemination to course participants + course CourseId + name (CI Text) + type Text Maybe + description Html Maybe + visibleFrom UTCTime Maybe -- Invisible to enrolled participants before + lastEdit UTCTime + UniqueMaterial course name + deriving Generic +MaterialFile -- a file that is part of a material distribution + material MaterialId + file FileId \ No newline at end of file diff --git a/package.yaml b/package.yaml index 66afc05b0..4edc4d864 100644 --- a/package.yaml +++ b/package.yaml @@ -125,6 +125,7 @@ dependencies: - lifted-async - streaming-commons - hourglass + - unix other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 5ab08b660..747207cc0 100644 --- a/routes +++ b/routes @@ -39,86 +39,95 @@ /favicon.ico FaviconR GET !free /robots.txt RobotsR GET !free -/ HomeR GET !free -/users UsersR GET -- no tags, i.e. admins only -/users/#CryptoUUIDUser AdminUserR GET POST -/users/#CryptoUUIDUser/delete AdminUserDeleteR POST -/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation -/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self -/admin AdminR GET -/admin/features AdminFeaturesR GET POST -/admin/test AdminTestR GET POST -/admin/errMsg AdminErrMsgR GET POST +/ HomeR GET !free +/users UsersR GET -- no tags, i.e. admins only +/users/#CryptoUUIDUser AdminUserR GET POST +/users/#CryptoUUIDUser/delete AdminUserDeleteR POST +/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation +/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self +/admin AdminR GET +/admin/features AdminFeaturesR GET POST +/admin/test AdminTestR GET POST +/admin/errMsg AdminErrMsgR GET POST -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !lecturer -/info/data DataProtR GET !free -/impressum ImpressumR GET !free -/version VersionR GET !free +/health HealthR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !lecturer +/info/data DataProtR GET !free +/impressum ImpressumR GET !free +/version VersionR GET !free -/help HelpR GET POST !free +/help HelpR GET POST !free -/user ProfileR GET POST !free -/user/profile ProfileDataR GET !free -/user/authpreds AuthPredsR GET POST !free +/user ProfileR GET POST !free +/user/profile ProfileDataR GET !free +/user/authpreds AuthPredsR GET POST !free -/term TermShowR GET !free -/term/current TermCurrentR GET !free -/term/edit TermEditR GET POST -/term/#TermId/edit TermEditExistR GET POST -!/term/#TermId TermCourseListR GET !free -!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free +/term TermShowR GET !free +/term/current TermCurrentR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET POST +!/term/#TermId TermCourseListR GET !free +!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET !development -/school/#SchoolId SchoolShowR GET !development +/school SchoolListR GET !development +/school/#SchoolId SchoolShowR GET !development -- For Pattern Synonyms see Foundation -/course/ CourseListR GET !free -!/course/new CourseNewR GET POST !lecturer -/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: - / CShowR GET !free - /register CRegisterR POST !timeANDcapacity - /edit CEditR GET POST - /lecturer-invite CLecInviteR GET POST - /delete CDeleteR GET POST !lecturerANDempty - /users CUsersR GET POST - /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant - /correctors CHiWisR GET - /communication CCommR GET POST - /notes CNotesR GET POST !corrector - /subs CCorrectionsR GET POST - /ex SheetListR GET !course-registered !materials !corrector - /ex/new SheetNewR GET POST - /ex/current SheetCurrentR GET !course-registered !materials !corrector - /ex/unassigned SheetOldUnassigned GET +/course/ CourseListR GET !free +!/course/new CourseNewR GET POST !lecturer +/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: + / CShowR GET !free + /register CRegisterR GET POST !timeANDcapacity + /edit CEditR GET POST + /lecturer-invite CLecInviteR GET POST + /delete CDeleteR GET POST !lecturerANDempty + /users CUsersR GET POST + /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant + /correctors CHiWisR GET + /communication CCommR GET POST + /notes CNotesR GET POST !corrector + /subs CCorrectionsR GET POST + /ex SheetListR GET !course-registered !materials !corrector + /ex/new SheetNewR GET POST + /ex/current SheetCurrentR GET !course-registered !materials !corrector + /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: - /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector - /edit SEditR GET POST - /delete SDelR GET POST - /subs SSubsR GET POST -- for lecturer only - !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions - !/subs/own SubmissionOwnR GET !free -- just redirect + /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector + /edit SEditR GET POST + /delete SDelR GET POST + /subs SSubsR GET POST -- for lecturer only + !/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions + !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread - /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector - /delete SubDelR GET POST !ownerANDtime - /assign SAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDreadANDrated - !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector - /correctors SCorrR GET POST - /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions - /corrector-invite SCorrInviteR GET POST - !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector - /tuts CTutorialListR GET !tutor + / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread + /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector + /delete SubDelR GET POST !ownerANDtime + /assign SAssignR GET POST !lecturerANDtime + /correction CorrectionR GET POST !corrector !ownerANDreadANDrated + !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector + /correctors SCorrR GET POST + /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions + /corrector-invite/ SCorrInviteR GET POST + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + /file MaterialListR GET !course-registered !materials !corrector !tutor + /file/new MaterialNewR GET POST + /file/#MaterialName MaterialR: + /edit MEditR GET POST + /delete MDelR GET POST + /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + /load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + /tuts CTutorialListR GET !tutor /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: - /edit TEditR GET POST - /delete TDeleteR GET POST - /participants TUsersR GET POST !tutor - /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered - /communication TCommR GET POST !tutor - /tutor-invite TInviteR GET POST + /edit TEditR GET POST + /delete TDeleteR GET POST + /participants TUsersR GET POST !tutor + /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered + /communication TCommR GET POST !tutor + /tutor-invite TInviteR GET POST /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 77a19df68..cc8843303 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Application - ( getApplicationDev, getAppDevSettings + ( getAppDevSettings , appMain , develMain , makeFoundation @@ -64,7 +64,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..)) import qualified Data.HashMap.Strict as HashMap -import Control.Lens +import Utils.Lens import Data.Proxy @@ -76,7 +76,11 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) - +import System.Environment (lookupEnv) +import System.Posix.Process (getProcessID) + +import Control.Monad.Trans.State (execStateT) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -93,8 +97,10 @@ import Handler.Sheet import Handler.Submission import Handler.Tutorial import Handler.Corrections +import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage +import Handler.Health -- This line actually creates our YesodDispatch instance. It is the second half @@ -141,13 +147,14 @@ makeFoundation appSettings'@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO + appHealthReport <- liftIO $ newTVarIO Nothing -- 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 -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -160,6 +167,7 @@ makeFoundation appSettings'@AppSettings{..} = do (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -182,7 +190,7 @@ makeFoundation appSettings'@AppSettings{..} = do ldapPool <- for appLdapConf $ \LdapConf{..} -> do $logDebugS "setup" "LDAP-Pool" createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - + -- Perform database migration using our application's logging settings. $logDebugS "setup" "Migration" migrateAll `runSqlPool` sqlPool @@ -191,11 +199,9 @@ makeFoundation appSettings'@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool + appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet - - $logDebugS "setup" "Job-Handling" - handleJobs foundation + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID -- Return the foundation $logDebugS "setup" "Done" @@ -226,7 +232,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do new <- initClusterSetting proxy void . insert $ ClusterConfig key (Aeson.toJSON new) return new - + readInstanceIDFile :: MonadIO m => FilePath -> m UUID readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS where @@ -247,7 +253,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do let withLogging :: LoggingT IO a -> IO a withLogging = flip runLoggingT logFunc - + mkConnection = withLogging $ do $logInfoS "SMTP" "Opening new connection" liftIO mkConnection' @@ -311,8 +317,16 @@ makeLogWare app = do warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings & setBeforeMainLoop (runAppLoggingT foundation $ do - $logInfoS "setup" "Ready" - void $ liftIO Systemd.notifyReady + let notifyReady = do + $logInfoS "setup" "Ready" + void $ liftIO Systemd.notifyReady + if + | foundation ^. _appHealthCheckDelayNotify + -> void . fork $ do + atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd) + notifyReady + | otherwise + -> notifyReady ) & setHost (foundation ^. _appHost) & setPort (foundation ^. _appPort) @@ -327,39 +341,44 @@ warpSettings foundation = defaultSettings LevelError (toLogStr $ "Exception from Warp: " ++ show e)) --- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application) -getApplicationDev = do - settings <- getAppDevSettings - foundation <- makeFoundation settings - wsettings <- liftIO . getDevSettings $ warpSettings foundation - app <- makeApplication foundation - return (wsettings, app) +getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings +getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv -getAppDevSettings :: MonadIO m => m AppSettings -getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +adjustSettings :: MonadIO m => AppSettings -> m AppSettings +adjustSettings = execStateT $ do + watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC" + watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID" + myProcessID <- liftIO getProcessID + case watchdogMicroSec of + Just wInterval + | maybe True (== myProcessID) watchdogProcess + -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2) + _other -> return () -- | main function for use by yesod devel develMain :: IO () -develMain = runResourceT $ - liftIO . develMainHelper . return =<< getApplicationDev +develMain = runResourceT $ do + settings <- getAppDevSettings + foundation <- makeFoundation settings + wsettings <- liftIO . getDevSettings $ warpSettings foundation + app <- makeApplication foundation + + handleJobs foundation + liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. appMain :: MonadResourceBase m => m () appMain = runResourceT $ do - -- Get the settings from all relevant sources - settings <- liftIO $ - loadYamlSettingsArgs - -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] - - -- allow environment variables to override - useEnv + settings <- getAppSettings -- Generate the foundation from the settings foundation <- makeFoundation settings - + runAppLoggingT foundation $ do + $logDebugS "setup" "Job-Handling" + handleJobs foundation + -- Generate a WAI Application from the foundation app <- makeApplication foundation @@ -388,18 +407,19 @@ appMain = runResourceT $ do -------------------------------------------------------------- foundationStoreNum :: Word32 foundationStoreNum = 2 - + getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings + handleJobs foundation wsettings <- liftIO . getDevSettings $ warpSettings foundation app1 <- makeApplication foundation let foundationStore = Store foundationStoreNum liftIO $ deleteStore foundationStore liftIO $ writeStore foundationStore foundation - + return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 990c782ff..38105a37a 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -19,9 +19,9 @@ import Database.Esqueleto.Utils.TH -- --- Description : Convenience for using @Esqueleto@, +-- Description : Convenience for using `Esqueleto`, -- intended to be imported qualified --- just like Esqueleto +-- just like @Esqueleto@ -- ezero = E.val (0 :: Int64) @@ -44,13 +44,13 @@ hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) => hasInfix = flip isInfixOf -- | Given a test and a set of values, check whether anyone succeeds the test --- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated) +-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) any :: Foldable f => (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) any test = F.foldr (\needle acc -> acc E.||. test needle) false -- | Given a test and a set of values, check whether all succeeds the test --- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated) +-- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated) all :: Foldable f => (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) all test = F.foldr (\needle acc -> acc E.&&. test needle) true @@ -82,7 +82,7 @@ mkExactFilter :: (PersistField a) -> E.SqlExpr (E.Value Bool) mkExactFilter = mkExactFilterWith id --- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ +-- | like `mkExactFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` mkExactFilterWith :: (PersistField b) => (a -> b) -- ^ type conversion -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element diff --git a/src/Foundation.hs b/src/Foundation.hs index 88b202949..71999df4a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -113,17 +113,19 @@ data UniWorX = UniWorX , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool , appLdapPool :: Maybe LdapPool - , appWidgetMemcached :: Maybe Memcached.Connection + , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool , appHttpManager :: Manager , appLogger :: (ReleaseKey, TVar Logger) , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey + , appClusterID :: ClusterId , appInstanceID :: InstanceId , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) , appCronThread :: TMVar (ReleaseKey, ThreadId) , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet + , appHealthReport :: TVar (Maybe (UTCTime, HealthReport)) } makeLenses_ ''UniWorX @@ -161,9 +163,13 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX +pattern CMaterialR tid ssh csh mnm ptn + = CourseR tid ssh csh (MaterialR mnm ptn) + pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX -pattern CTutorialR tid ssh csh shn ptn - = CourseR tid ssh csh (TutorialR shn ptn) +pattern CTutorialR tid ssh csh tnm ptn + = CourseR tid ssh csh (TutorialR tnm ptn) pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn @@ -636,9 +642,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of -> return Authorized | otherwise -> mzero - + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let @@ -660,6 +666,14 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized + CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm + cTime <- liftIO getCurrentTime + let visible = NTop materialVisibleFrom <= NTop (Just cTime) + guard visible + return Authorized + CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- getBy $ TermSchoolCourseShort tid ssh csh @@ -699,18 +713,6 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route return Authorized r -> $unsupportedAuthPredicate AuthCourseRegistered r tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) - return Authorized CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do @@ -724,6 +726,18 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do @@ -974,6 +988,22 @@ evalAccess route isWrite = do evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB = evalAccess +-- | Check whether the current user is authorized by `evalAccess` for the given route +-- Convenience function for a commonly used code fragment +hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite + +-- | Check whether the current user is authorized by `evalAccess` to read from the given route +-- Convenience function for a commonly used code fragment +hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo = flip hasAccessTo False + +-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route +-- Convenience function for a commonly used code fragment +hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo = flip hasAccessTo True + +-- | Conditional redirect that hides the URL if the user is not authorized for the route redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do -- must hide URL if not authorized @@ -1160,6 +1190,8 @@ siteLayout' headingOverride widget = do isModal <- hasCustomHeader HeaderIsModal + primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages + mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. @@ -1279,6 +1311,7 @@ siteLayout' headingOverride widget = do addScript $ StaticR js_utils_checkAll_js addScript $ StaticR js_utils_form_js addScript $ StaticR js_utils_inputs_js + addScript $ StaticR js_utils_massInput_js addScript $ StaticR js_utils_modal_js addScript $ StaticR js_utils_showHide_js -- addScript $ StaticR js_utils_tabber_js @@ -1346,6 +1379,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb HelpR = return ("Hilfe" , Just HomeR) + breadcrumb HealthR = return ("Status" , Nothing) + breadcrumb InstanceR = return ("Identifikation", Nothing) + + breadcrumb ProfileR = return ("User" , Just HomeR) breadcrumb ProfileDataR = return ("Profile" , Just ProfileR) breadcrumb AuthPredsR = return ("Authentifizierung", Just ProfileR) @@ -1389,6 +1426,14 @@ instance YesodBreadcrumbs UniWorX where -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads + + breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material" , Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu" , Just $ CourseR tid ssh csh MaterialListR) + breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten" , Just $ CMaterialR tid ssh csh mnm MShowR) + breadcrumb (CMaterialR tid ssh csh mnm MDelR) = return ("Löschen" , Just $ CMaterialR tid ssh csh mnm MShowR) + -- (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads + -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) @@ -1649,6 +1694,26 @@ pageActions (VersionR) = [ , menuItemAccessCallback' = return True } ] +pageActions HealthR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuInstance + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute InstanceR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions InstanceR = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuHealth + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute HealthR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (HelpR) = [ -- MenuItem -- { menuItemType = PageActionPrime @@ -1727,6 +1792,25 @@ pageActions (CourseNewR) = [ ] pageActions (CourseR tid ssh csh CShowR) = [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR + , menuItemModal = False + , menuItemAccessCallback' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers that can create new material + materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- or show if user can see at least one of the contents + existsVisible = do + matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do + E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ material E.^. MaterialName + anyM matNames (materialAccess . E.unValue) + in runDB $ lecturerAccess `or2M` existsVisible + } + , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing @@ -1855,6 +1939,34 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh MaterialListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CMaterialR tid ssh csh mnm MShowR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMaterialDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CourseR tid ssh csh CTutorialListR) = [ MenuItem { menuItemType = PageActionPrime @@ -2184,6 +2296,7 @@ pageHeading (CourseR tid ssh csh SheetNewR) = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh pageHeading (CSheetR tid ssh csh shn SShowR) = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn + -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity pageHeading (CSheetR tid ssh csh shn SEditR) = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn pageHeading (CSheetR tid ssh csh shn SDelR) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2180e28e8..943e34e9a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -205,7 +205,7 @@ postAdminTestR = do -- The actual call to @massInput@ is comparatively simple: - ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 54eddd1c3..f11a76cfb 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -8,10 +8,19 @@ import Import hiding (embedFile) -- runtime dependency, and for efficiency. getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - return $ TypedContent "image/x-icon" - $ toContent $(embedFile "static/favicon.ico") +getFaviconR = do + let content = $(embedFile "static/favicon.ico") + + setEtagHashable content + + return $ TypedContent "image/x-icon" + $ toContent content getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "static/robots.txt") +getRobotsR = do + let content = $(embedFile "static/robots.txt") + + setEtagHashable content + + return $ TypedContent typePlain + $ toContent content diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e05481c8a..003fdfcdc 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -396,7 +396,7 @@ getCShowR tid ssh csh = do tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"] (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable - + siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") @@ -435,6 +435,19 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist isRegistered = isJust participant +-- | Workaround for klicking register button without being logged in. +-- After log in, the user sees a "get request not supported" error. +getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCRegisterR tid ssh csh = do + muid <- maybeAuthId + case muid of + Nothing -> addMessageI Info MsgLoginNecessary + (Just uid) -> runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + registration <- getBy (UniqueParticipant uid cid) + when (isNothing registration) $ addMessageI Warning MsgRegisterRetry + redirect $ CourseR tid ssh csh CShowR + postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do aid <- requireAuthId @@ -808,6 +821,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") + miIdent :: Text + miIdent = "lecturers" + lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput @@ -1180,7 +1196,7 @@ postTUsersR tid ssh csh tutn = do ] addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR - + let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName siteLayoutMsg heading $ do setTitleI heading diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs new file mode 100644 index 000000000..872ab3410 --- /dev/null +++ b/src/Handler/Health.hs @@ -0,0 +1,81 @@ +module Handler.Health where + +import Import + +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.Text.Lazy.Builder as Builder + +import Utils.Lens + +import qualified Data.UUID as UUID + + +getHealthR :: Handler TypedContent +getHealthR = do + healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport + let + handleMissing = do + interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval + reportStore <- getsYesod appHealthReport + waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just) + case waitResult of + Left () -> fail "System is not generating HealthReports" + Right _ -> redirect HealthR + (lastUpdated, healthReport) <- maybe handleMissing return healthReport' + interval <- getsYesod $ view _appHealthCheckInterval + instanceId <- getsYesod appInstanceID + + setWeakEtagHashable (instanceId, lastUpdated) + expiresAt $ interval `addUTCTime` lastUpdated + setLastModified lastUpdated + + let status + | HealthSuccess <- classifyHealthReport healthReport + = ok200 + | otherwise + = internalServerError500 + sendResponseStatus status <=< selectRep $ do + provideRep . siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + let HealthReport{..} = healthReport + [whamlet| + $newline never +
+
_{MsgHealthMatchingClusterConfig} +
#{boolSymbol healthMatchingClusterConfig} + $maybe httpReachable <- healthHTTPReachable +
_{MsgHealthHTTPReachable} +
#{boolSymbol httpReachable} + $maybe ldapAdmins <- healthLDAPAdmins +
_{MsgHealthLDAPAdmins} +
#{textPercent ldapAdmins} + $maybe smtpConnect <- healthSMTPConnect +
_{MsgHealthSMTPConnect} +
#{boolSymbol smtpConnect} + $maybe widgetMemcached <- healthWidgetMemcached +
_{MsgHealthWidgetMemcached} +
#{boolSymbol widgetMemcached} + |] + provideJson healthReport + provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport + +getInstanceR :: Handler TypedContent +getInstanceR = do + instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID + + setWeakEtagHashable (clusterId, instanceId) + + selectRep $ do + provideRep $ + siteLayoutMsg MsgInstanceIdentification $ do + setTitleI MsgInstanceIdentification + [whamlet| + $newline never +
+
_{MsgClusterId} +
#{UUID.toText clusterId} +
_{MsgInstanceId} +
#{UUID.toText instanceId} + |] + provideJson instanceInfo + provideRep . return $ tshow instanceInfo diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs new file mode 100644 index 000000000..86b1789e6 --- /dev/null +++ b/src/Handler/Material.hs @@ -0,0 +1,301 @@ +module Handler.Material where + +import Import + +import Data.Monoid (Any(..)) +import Data.Set (Set) +import qualified Data.Set as Set +-- import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Conduit.List as C +-- import qualified Data.CaseInsensitive as CI + +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils.TH + +import Utils.Lens +import Utils.Form +import Handler.Utils +-- import Handler.Utils.Delete +import Handler.Utils.Table.Cells +import Handler.Utils.Table.Columns + +import Control.Monad.Writer (MonadWriter(..), execWriterT) + + + + +data MaterialForm = MaterialForm + { mfName :: MaterialName + , mfType :: Maybe Text + , mfDescription :: Maybe Html + , mfVisibleFrom :: Maybe UTCTime + , mfFiles :: Maybe (Source Handler (Either FileId File)) + } + +makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm +makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do + MsgRenderer mr <- getMsgRenderer + let setIds :: Either FileId File -> Set FileId + setIds = either Set.singleton $ const Set.empty + oldFileIds + | Just source <- template >>= mfFiles + = runConduit $ source .| C.foldMap setIds + | otherwise = return Set.empty + typeOptions :: WidgetT UniWorX IO (Set Text) + typeOptions = do + let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] + previouslyUsed <- liftHandlerT . runDB $ + E.select $ E.from $ \material -> + E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) + return $ material E.^. MaterialType + return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed) + + ctime <- ceilingQuarterHour <$> liftIO getCurrentTime + flip (renderAForm FormStandard) html $ MaterialForm + <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) + <*> aopt (textField & addDatalist typeOptions) + (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) + (mfType <$> template) + <*> aopt htmlField (fslpI MsgMaterialDescription "Html") + (mfDescription <$> template) + <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom + & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) + <*> aopt (multiFileField oldFileIds) + (fslI MsgMaterialFiles) (mfFiles <$> template) + +fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) +fetchMaterial tid ssh csh mnm = do + [matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints + \(course `E.InnerJoin` material) -> do + E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. material E.^. MaterialName E.==. E.val mnm + return material + return matEnt + + +getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialListR tid ssh csh = do + let matLink :: MaterialName -> Route UniWorX + matLink = CourseR tid ssh csh . flip MaterialR MShowR + now <- liftIO getCurrentTime + table <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let row2material = entityVal . dbrOutput -- no inner join, just Entity Material + psValidator = def & defaultSorting [SortDescBy "last-edit"] + dbTableWidget' psValidator DBTable + { dbtIdent = "material-list" :: Text + , dbtStyle = def + , dbtParams = def + , dbtSQLQuery = \material -> do + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + return material + , dbtRowKey = (E.^. MaterialId) + -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr + , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) + , dbtColonnade = widgetColonnade $ mconcat + [ dbRow + , sortable (Just "type") (i18nCell MsgMaterialType) + $ foldMap textCell . materialType . row2material + , sortable (Just "name") (i18nCell MsgMaterialName) + $ liftA2 anchorCell matLink toWgt . materialName . row2material + , sortable (toNothingS "description") mempty + $ foldMap modalCell . materialDescription . row2material + , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) + $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material + , sortable (Just "last-edit") (i18nCell MsgFileModified) + $ dateTimeCell . materialLastEdit . row2material + ] + , dbtSorting = Map.fromList + [ ( "type" , SortColumn (E.^. MaterialType) ) + , ( "name" , SortColumn (E.^. MaterialName) ) + , ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) ) + , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) + ] + , dbtFilter = mempty + , dbtFilterUI = mempty + } + + let headingLong = prependCourseTitle tid ssh csh MsgMaterialListHeading + headingShort = prependCourseTitle tid ssh csh MsgMaterialListHeading + siteLayoutMsg headingLong $ do + setTitleI headingShort + $(widgetFile "material-list") + + +getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent +getMFileR tid ssh csh mnm title = serveOneFile fileQuery + where + fileQuery = E.select $ E.from $ + \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do + -- Restrict to consistent rows that correspond to each other + E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) + E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId) + E.on (material E.^. MaterialCourse E.==. course E.^. CourseId) + -- filter to requested file + E.where_ ((file E.^. FileTitle E.==. E.val title) + E.&&. (material E.^. MaterialName E.==. E.val mnm ) + E.&&. (course E.^. CourseShorthand E.==. E.val csh ) + E.&&. (course E.^. CourseSchool E.==. E.val ssh ) + E.&&. (course E.^. CourseTerm E.==. E.val tid ) + ) + -- return file entity + return file + +getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMShowR tid ssh csh mnm = do + let matLink :: FilePath -> Route UniWorX + matLink = CourseR tid ssh csh . MaterialR mnm . MFileR + ( Entity _mid material@Material{materialType, materialDescription} + , (Any hasFiles,fileTable)) <- runDB $ do + matEnt <- fetchMaterial tid ssh csh mnm + let psValidator = def & defaultSortingByFileTitle + fileTable' <- dbTable psValidator DBTable + { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do + E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId + E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) + E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories + return (file E.^. FileTitle, file E.^. FileModified) + , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId + , dbtColonnade = widgetColonnade $ mconcat + [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty + , colFilePathSimple (view $ _dbrOutput . _1) matLink + , colFileModification (view $ _dbrOutput . _2) + ] + , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr + , dbtStyle = def + , dbtParams = def + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtIdent = "material-files" :: Text + , dbtSorting = Map.fromList + [ sortFilePath $(sqlIJproj 2 2) + , sortFileModification $(sqlIJproj 2 2) + ] + } + return (matEnt,fileTable') + + let matVisFro = materialVisibleFrom material + now <- liftIO getCurrentTime + materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material + materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro + when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $ + maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom + + let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm + headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm + siteLayoutMsg headingLong $ do + setTitleI headingShort + $(widgetFile "material-show") + + +getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMEditR = postMEditR +postMEditR tid ssh csh mnm = do + (Entity mid Material{..}, files) <- runDB $ do + matEnt <- fetchMaterial tid ssh csh mnm + fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do + E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId + E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) + return $ file E.^. FileId + return (matEnt, (Left . E.unValue) <$> fileIds) + -- let cid = materialCourse + let template = Just MaterialForm + { mfName = materialName + , mfType = materialType + , mfDescription = materialDescription + , mfVisibleFrom = materialVisibleFrom + , mfFiles = Just $ yieldMany files + } + editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid + let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm + headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm + siteLayoutMsg headingLong $ do + setTitleI headingShort + editWidget + + +getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialNewR = postMaterialNewR +postMaterialNewR tid ssh csh = do + Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique + let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading + headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle + siteLayoutMsg headingLong $ do + setTitleI headingShort + editWidget + +handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget +handleMaterialEdit tid ssh csh cid template dbMaterial = do + ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template + formResult res saveMaterial + -- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute + return $ wrapForm formWidget def + { formAction = Nothing -- Just $ SomeRoute actionUrl + , formEncoding = formEnctype + } + where + saveMaterial :: MaterialForm -> Handler () + saveMaterial MaterialForm{..} = do + _aid <- requireAuthId + now <- liftIO getCurrentTime + let newMaterial = Material + { materialCourse = cid + , materialName = mfName + , materialType = mfType + , materialDescription = mfDescription + , materialVisibleFrom = mfVisibleFrom + , materialLastEdit = now + } + saveOk <- runDB $ do + mbmid <- dbMaterial newMaterial + case mbmid of + Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName) + (Just mid) -> do -- save files in DB + whenIsJust mfFiles $ insertMaterialFile' mid + addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName + -- more info/warnings could go here + return True + when saveOk $ redirect -- redirect must happen outside of runDB + $ CourseR tid ssh csh (MaterialR mfName MShowR) + + insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () + insertMaterialFile' mid fs = do + oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do + E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId + E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid + return $ file E.^. FileId + let oldFileIds = setFromList $ map E.unValue oldFileIdVals + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) + where + finsert (Left fileId) = tell $ singleton fileId + finsert (Right file) = lift $ do + fid <- insert file + void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step + + +getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMDelR = postMDelR +postMDelR tid ssh csh mnm = do + _matEnt <- runDB $ fetchMaterial tid ssh csh mnm + error "todo" -- CONTINUE HERE + {- + deleteR DeleteRoute + { drRecords = Set.singleton $ entityKey matEnt + , drGetInfo = error "todo" + , drUnjoin = error "todo" + , drRenderRecord = error "todo" + , drRecordConfirmString = error "todo" + , drCaption = SomeMessage MsgMaterialDeleteQuestion + , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm + , drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR + , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR + } + -} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 478f00a91..b4d549d49 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -6,12 +6,12 @@ import Import import Jobs.Queue -import System.FilePath (takeFileName) - +-- import Utils.Lens import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells +-- import Handler.Utils.Table.Columns import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Form.MassInput @@ -41,8 +41,6 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) -import Network.Mime - import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map @@ -102,10 +100,11 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId mr <- getMsgRenderer - ctime <- liftIO $ getCurrentTime + ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) - <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) + <*> aopt htmlField (fslpI MsgSheetDescription "Html") + (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) (sfType <$> template) @@ -161,7 +160,8 @@ getSheetOldUnassigned tid ssh csh = runDB $ do getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do muid <- maybeAuthId - Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh let lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId @@ -182,9 +182,9 @@ getSheetListR tid ssh csh = do , sortable (Just "name") (i18nCell MsgSheet) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) - $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime - , sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom) - $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom + $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime + , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) @@ -310,43 +310,43 @@ getSShowR tid ssh csh shn = do -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes -- with Colonnade - let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do + let fileData (sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) - E.on (sheetFile E.^. SheetFileSheet E.==. sheet' E.^. SheetId) + E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) -- filter to requested file - E.where_ $ sheet' E.^. SheetId E.==. E.val sid - E.&&. E.not_ (E.isNothing $ file E.^. FileContent) + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid + E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) - , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell - (CSheetR tid ssh csh shn (SFileR fType fName)) - (str2widget fName) - , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget + [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) + , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell + (CSheetR tid ssh csh shn (SFileR fType fName)) + (str2widget fName) + -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) + -- , colFileModification (view _2) + , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified ] - let psValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "path"] + let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData - , dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId + , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } - -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) + -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput , dbtStyle = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" - , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType + , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType ) , ( "path" - , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle + , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) , ( "time" - , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified + , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) ] , dbtParams = def @@ -371,7 +371,7 @@ getSShowR tid ssh csh shn = do , formSubmit = FormNoSubmit } defaultLayout $ do - setTitleI $ MsgSheetTitle tid ssh csh shn + setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet @@ -405,34 +405,24 @@ postSPseudonymR tid ssh csh shn = do getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid ssh csh shn typ title = do - results <- runDB $ E.select $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do - -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) - E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) - -- filter to requested file - E.where_ ((file E.^. FileTitle E.==. E.val title) - E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) - E.&&. (sheet E.^. SheetName E.==. E.val shn ) - E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseSchool E.==. E.val ssh ) - E.&&. (course E.^. CourseTerm E.==. E.val tid ) - ) - -- return desired columns - return $ (file E.^. FileTitle, file E.^. FileContent) - case results of - [(E.Value fileTitle, E.Value fileContent)] - | Just fileContent' <- fileContent -> do - whenM downloadFiles $ - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') - | otherwise -> sendResponseStatus noContent204 () - [] -> notFound - other -> do - $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other - error "Multiple matching files found." +getSFileR tid ssh csh shn typ title = serveOneFile fileQuery + where + fileQuery = E.select $ E.from $ + \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do + -- Restrict to consistent rows that correspond to each other + E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) + E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) + E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) + -- filter to requested file + E.where_ ((file E.^. FileTitle E.==. E.val title) + E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) + E.&&. (sheet E.^. SheetName E.==. E.val shn ) + E.&&. (course E.^. CourseShorthand E.==. E.val csh ) + E.&&. (course E.^. CourseSchool E.==. E.val ssh ) + E.&&. (course E.^. CourseTerm E.==. E.val tid ) + ) + -- return file entity + return file getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do @@ -508,11 +498,7 @@ getSEditR tid ssh csh shn = do , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingText = sheetMarkingText } - let action newSheet = do - replaceRes <- myReplaceUnique sid $ newSheet - case replaceRes of - Nothing -> return $ Just sid - (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here + let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead handleSheetEdit tid ssh csh (Just sid) template action postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html @@ -570,10 +556,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle - wrapForm formWidget def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = formEnctype - } + let sheetEditForm = wrapForm formWidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = formEnctype + } + $(i18nWidgetFile "sheet-edit") getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html @@ -749,6 +736,9 @@ correctorForm shid = wFormToAForm $ do -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout") + miIdent :: Text + miIdent = "correctors" + postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector) postProcess = Set.fromList . map postProcess' . Map.elems where diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index abf1421bd..08e960581 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -256,7 +256,7 @@ newTermForm template html = do = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid | otherwise = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing - holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty + holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty (result, widget) <- flip (renderAForm FormStandard) html $ Term <$> tidForm <*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template) diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index c32de13bb..255f26aea 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -280,7 +280,7 @@ tutorialForm cid template html = do uid <- liftHandlerT requireAuthId let - tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) + tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) where miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd' nudge submitView csrf = do @@ -312,7 +312,7 @@ tutorialForm cid template html = do <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurencesAForm (tfTime <$> template) + <*> occurencesAForm ("occurences" :: Text) (tfTime <$> template) <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 46c4e8631..8e2a595e2 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -30,7 +30,9 @@ import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils import System.Directory (listDirectory) -import System.FilePath.Posix (takeBaseName) +import System.FilePath.Posix (takeBaseName, takeFileName) + +import Network.Mime import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty @@ -45,6 +47,22 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles +-- | Serve a single file, identified through a given DB query +serveOneFile :: DB [Entity File] -> Handler TypedContent +serveOneFile query = do + results <- runDB query + case results of + [Entity _fileId File{fileTitle, fileContent}] + | Just fileContent' <- fileContent -> do + whenM downloadFiles $ + addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + | otherwise -> sendResponseStatus noContent204 () + [] -> notFound + other -> do + $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other + error "Multiple matching files found." + tidFromText :: Text -> Maybe TermId tidFromText = fmap TermKey . maybeRight . termFromText @@ -171,3 +189,12 @@ i18nWidgetFile basename = do | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] + + + +-- | return a value only if the current user ist authorized for a given route +guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h + , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) + => Route UniWorX -> a -> m (ReaderT SqlBackend h) a +guardAuthorizedFor link val = + val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 9ca46ae15..c82c574ee 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -165,6 +165,8 @@ commR CommunicationRoute{..} = do miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition)) -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . filter snd . Map.elems diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index dc5a59c06..16ab29afa 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -9,6 +9,7 @@ module Handler.Utils.DateTime , addOneWeek, addWeeks , weeksToAdd , setYear + , ceilingQuarterHour ) where import Import @@ -190,3 +191,17 @@ weeksToAdd old new = loop 0 old loop n t | t > new = n | otherwise = loop (succ n) (addOneWeek t) + +-- | round up the next full quarter hour with a margin of at least 5 minutes +ceilingQuarterHour :: UTCTime -> UTCTime +ceilingQuarterHour = ceilingMinuteBy 5 15 + +-- | round up the next full @roundto@ minutes with a margin of at least @margin@ minutes +ceilingMinuteBy :: Int -> Int -> UTCTime -> UTCTime +ceilingMinuteBy margin roundto utct = addUTCTime bonus utct + where + oldTime = localTimeOfDay $ utcToLocalTime utct + oldMin = todMin oldTime + newMin = roundToNearestMultiple roundto $ oldMin + margin + newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime` + bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bc0817d50..94504f1ea 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -37,7 +37,6 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Data.Scientific (Scientific) -import Data.Ratio import Text.Read (readMaybe) import Data.Either (partitionEithers) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index c91b60d20..664b0f3c7 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -37,6 +37,8 @@ import qualified Data.Foldable as Fold import Control.Monad.Reader.Class (MonadReader(local)) +import Text.Hamlet (hamletFile) + $(mapM tupleBoxCoord [2..4]) @@ -232,7 +234,7 @@ data MassInputException = MassInputInvalidShape instance Exception MassInputException -data MassInput handler liveliness cellData cellResult = MassInput +data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero) -> Natural -- Zero-based dimension index @dimIx@ -> (Text -> Text) -- Nudge deterministic field ids @@ -256,6 +258,7 @@ data MassInput handler liveliness cellData cellResult = MassInput -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment` , miLayout :: MassInputLayout liveliness cellData cellResult + , miIdent :: i } type MassInputLayout liveliness cellData cellResult @@ -277,7 +280,7 @@ massInput :: forall handler cellData cellResult liveliness. -> Bool -- ^ Required? -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult)) -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX)) -massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do +massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvRequired initialResult csrf = do let initialShape = fmap fst <$> initialResult miName <- maybe newFormIdent return fsName @@ -413,6 +416,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do MsgRenderer mr <- getMsgRenderer + whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do + PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone") + ur <- getUrlRenderParams + + sendResponse $ $(hamletFile "templates/widgets/massinput/massinput-standalone-wrapper.hamlet") ur + let fvLabel = toHtml $ mr fsLabel fvTooltip = toHtml . mr <$> fsTooltip @@ -446,18 +455,20 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints -massInputList :: forall handler cellResult. +massInputList :: forall handler cellResult ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX , MonadLogger handler + , PathPiece ident ) => Field handler cellResult -> (ListPosition -> FieldSettings UniWorX) -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> ident -> FieldSettings UniWorX -> Bool -> Maybe [cellResult] -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX)) -massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput +massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf -> return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn) , miCell = \pos () iRes nudge csrf -> @@ -467,26 +478,29 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes , miAddEmpty = \_ _ _ -> Set.empty , miButtonAction , miLayout = listMiLayout + , miIdent } miSettings miRequired (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult) -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition -massInputAccum :: forall handler cellData. +massInputAccum :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX , MonadLogger handler , ToJSON cellData, FromJSON cellData + , PathPiece ident ) => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) -> (cellData -> Widget) -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> MassInputLayout ListLength cellData () + -> ident -> FieldSettings UniWorX -> Bool -> Maybe [cellData] -> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX)) -massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev csrf +massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf = over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf where miAdd :: ListPosition -> Natural @@ -510,21 +524,23 @@ massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev miAddEmpty _ _ _ = Set.empty -massInputAccumA :: forall handler cellData. +massInputAccumA :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX , MonadLogger handler , ToJSON cellData, FromJSON cellData + , PathPiece ident ) => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) -> (cellData -> Widget) -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> MassInputLayout ListLength cellData () + -> ident -> FieldSettings UniWorX -> Bool -> Maybe [cellData] -> AForm handler [cellData] -massInputAccumA miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev - = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev mempty +massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev + = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty massInputA :: forall handler cellData cellResult liveliness. diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurences.hs index 4c5905b6b..d010c6a5e 100644 --- a/src/Handler/Utils/Form/Occurences.hs +++ b/src/Handler/Utils/Form/Occurences.hs @@ -34,8 +34,8 @@ nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''OccurenceExceptionKind id -occurencesAForm :: Maybe Occurences -> AForm Handler Occurences -occurencesAForm mPrev = wFormToAForm $ do +occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences +occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute let @@ -45,6 +45,7 @@ occurencesAForm mPrev = wFormToAForm $ do miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' + (miIdent' <> "__scheduled" :: Text) (fslI MsgScheduleRegular & setTooltip MsgMassInputTip) False (Set.toList . occurencesScheduled <$> mPrev) @@ -80,6 +81,7 @@ occurencesAForm mPrev = wFormToAForm $ do miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' + (miIdent' <> "__exceptions" :: Text) (fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip])) False (Set.toList . occurencesExceptions <$> mPrev) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 5b0cd1eee..84580b219 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -53,6 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act +markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a +markCell condition normal x + | condition x = normal x <> cell (isVisibleWidget False) + | otherwise = normal x + + +-- Recall: for line numbers, use dbRow --------------------- -- Icon cells @@ -75,6 +82,9 @@ commentCell Nothing = mempty commentCell (Just link) = anchorCell link icon where icon = toWidget $ hasComment True +-- | Display an icon that opens a modal upon clicking +modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a +modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) ----------------- -- Datatype cells @@ -87,6 +97,12 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget +dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a +dateTimeCellVisible watershed t = cell $ do + tfw <- formatTime SelFormatDateTime t >>= toWidget + icn <- bool mempty (toWidget $ isVisible False) $ watershed < t + return $ tfw <> icn + userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 25279fb96..1c125344b 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -11,6 +11,7 @@ import Import -- import Text.Blaze (ToMarkup(..)) +import Data.Monoid (Any(..)) import qualified Database.Esqueleto as E import Database.Esqueleto.Utils as E @@ -34,6 +35,54 @@ import Handler.Utils.Table.Cells -- * additional helper, such as default sorting +----------------------- +-- Numbers and Indices + +-- | Simple index column, also indicating whether there is a row at all +-- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead. +dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any) +dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex + + +--------------- +-- Files + +-- | Generic column for links to FilePaths, where the link depends on the entire table row +colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) +colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell + where + makeCell row = + let filePath = E.unValue $ row2path row + link = row2link row + in anchorCell link $ str2widget filePath + +-- | Generic column for links to FilePaths, where the link only depends on the FilePath itself +colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) +colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell + where + makeCell row = + let filePath = E.unValue $ row2path row + link = row2link filePath + in anchorCell link $ str2widget filePath + +-- | Generic column for File Modification +colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) +colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (dateTimeCell . E.unValue . row2time) + +sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) +sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle)) + +sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) +sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified)) + +defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x +defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] + +defaultSortingByFileModification :: PSValidator m x -> PSValidator m x +defaultSortingByFileModification = defaultSorting [SortAscBy "time"] + + + --------------- -- User names diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3e32e7028..36d2cfaca 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -931,7 +931,7 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell -- Predefined colonnades ---Number column? +-- | Simple number column, also see Handler.Utils.Table.Columns.dbRowIndicator dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index f23caf2aa..266ad727b 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -53,7 +53,7 @@ import Data.List.NonEmpty.Instances as Import () import Data.NonNull.Instances as Import () import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) import Data.Monoid.Instances as Import () import Data.Set.Instances as Import () import Data.HashMap.Strict.Instances as Import () @@ -96,6 +96,8 @@ import Time.Types.Instances as Import () import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) +import Data.Ratio as Import ((%)) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs.hs b/src/Jobs.hs index fd0b08c60..641d3e100 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -51,6 +51,8 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) +import qualified System.Systemd.Daemon as Systemd + import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -61,6 +63,8 @@ import Jobs.Handler.DistributeCorrections import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation +import Jobs.HealthReport + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -279,6 +283,21 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . void . flip swapTMVar newCTab =<< asks jobCrontab + handleCmd JobCtlGenerateHealthReport = do + hrStorage <- getsYesod appHealthReport + newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport + + $logInfoS "HealthReport" $ toPathPiece newStatus + unless (newStatus == HealthSuccess) $ do + $logErrorS "HealthReport" $ tshow newReport + + liftIO $ do + now <- getCurrentTime + atomically . writeTVar hrStorage $ Just (now, newReport) + + void . Systemd.notifyStatus . unpack $ toPathPiece newStatus + when (newStatus == HealthSuccess) $ + void Systemd.notifyWatchdog jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 434185d2b..5dd98d9b8 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -44,6 +44,15 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + tell $ HashMap.singleton + JobCtlGenerateHealthReport + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = appHealthCheckInterval + , cronNotAfter = Right CronNotScheduled + } + let sheetJobs (Entity nSheet Sheet{..}) = do tell $ HashMap.singleton diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs new file mode 100644 index 000000000..a8f6a0ff4 --- /dev/null +++ b/src/Jobs/HealthReport.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Jobs.HealthReport + ( generateHealthReport + ) where + +import Import + +import Data.List (genericLength) + +import qualified Data.Aeson as Aeson +import Data.Proxy (Proxy(..)) + +import qualified Data.ByteArray as ByteArray + +import Utils.Lens + +import Network.HTTP.Simple (httpJSON, httpLBS) +import qualified Network.HTTP.Simple as HTTP + +import qualified Database.Esqueleto as E + +import Auth.LDAP + +import qualified Data.CaseInsensitive as CI + +import qualified Network.HaskellNet.SMTP as SMTP +import Data.Pool (withResource) + + +generateHealthReport :: Handler HealthReport +generateHealthReport + = runConcurrently $ HealthReport + <$> Concurrently matchingClusterConfig + <*> Concurrently httpReachable + <*> Concurrently ldapAdmins + <*> Concurrently smtpConnect + <*> Concurrently widgetMemcached + +matchingClusterConfig :: Handler Bool +-- ^ Can the cluster configuration be read from the database and does it match our configuration? +matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches + where + clusterSettingMatches ClusterCryptoIDKey = do + ourSetting <- getsYesod appCryptoIDKey + dbSetting <- clusterSetting @'ClusterCryptoIDKey + return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting + clusterSettingMatches ClusterClientSessionKey = do + ourSetting <- getsYesod appSessionKey + dbSetting <- clusterSetting @'ClusterClientSessionKey + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterSecretBoxKey = do + ourSetting <- getsYesod appSecretBoxKey + dbSetting <- clusterSetting @'ClusterSecretBoxKey + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterJSONWebKeySet = do + ourSetting <- getsYesod appJSONWebKeySet + dbSetting <- clusterSetting @'ClusterJSONWebKeySet + return $ Just ourSetting == dbSetting + clusterSettingMatches ClusterId = do + ourSetting <- getsYesod appClusterID + dbSetting <- clusterSetting @'ClusterId + return $ Just ourSetting == dbSetting + + + clusterSetting :: forall key. + ( ClusterSetting key + ) + => DB (Maybe (ClusterSettingValue key)) + clusterSetting = do + current' <- get . ClusterConfigKey $ knownClusterSetting (Proxy @key) + case Aeson.fromJSON . clusterConfigValue <$> current' of + Just (Aeson.Success c) -> return $ Just c + _other -> return Nothing + + +httpReachable :: Handler (Maybe Bool) +httpReachable = do + staticAppRoot <- getsYesod $ view _appRoot + doHTTP <- getsYesod $ view _appHealthCheckHTTP + for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do + url <- getUrlRender <*> pure InstanceR + baseRequest <- HTTP.parseRequest $ unpack url + httpManager <- getsYesod appHttpManager + let httpRequest = baseRequest + & HTTP.setRequestManager httpManager + (clusterId, _ :: InstanceId) <- responseBody <$> httpJSON httpRequest + getsYesod $ (== clusterId) . appClusterID + + +ldapAdmins :: Handler (Maybe Rational) +ldapAdmins = do + ldapPool' <- getsYesod appLdapPool + ldapConf' <- getsYesod $ view _appLdapConf + ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP + return $ user E.^. UserIdent + case (,) <$> ldapPool' <*> ldapConf' of + Just (ldapPool, ldapConf) + | not $ null ldapAdminUsers + -> do + let numAdmins = genericLength ldapAdminUsers + hCampusExc :: CampusUserException -> Handler (Sum Integer) + hCampusExc _ = return $ Sum 0 + Sum numResolved <- fmap fold . forM ldapAdminUsers $ + \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent []) + return . Just $ numResolved % numAdmins + _other -> return Nothing + + +smtpConnect :: Handler (Maybe Bool) +smtpConnect = do + smtpPool <- getsYesod appSmtpPool + for smtpPool . flip withResource $ \smtpConn -> do + response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP + case rCode of + 250 -> return True + _ -> do + $logErrorS "Mail" $ "NOOP failed: " <> tshow response + return False + + +widgetMemcached :: Handler (Maybe Bool) +widgetMemcached = do + memcachedConn <- getsYesod appWidgetMemcached + for memcachedConn $ \_memcachedConn' -> do + let ext = "bin" + mimeType = "application/octet-stream" + content <- pack . take 256 <$> liftIO getRandoms + staticLink <- addStaticContent ext mimeType content + doHTTP <- getsYesod $ view _appHealthCheckHTTP + case staticLink of + _ | not doHTTP -> return True + Just (Left url) -> do + baseRequest <- HTTP.parseRequest $ unpack url + httpManager <- getsYesod appHttpManager + let httpRequest = baseRequest + & HTTP.setRequestManager httpManager + (== content) . responseBody <$> httpLBS httpRequest + _other -> return False + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 01800048e..f333f0c7d 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -69,6 +69,7 @@ data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId | JobCtlDetermineCrontab | JobCtlQueue Job + | JobCtlGenerateHealthReport deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Hashable JobCtl diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 875078b6f..6682d7c98 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -95,7 +95,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim setup <- newEmptyTMVarIO void . fork . flip runLoggingT logFunc $ do - $logDebugS "LdapExecutor" "Starting" + $logInfoS "LdapExecutor" "Starting" res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) case res of Left exc -> do diff --git a/src/Model.hs b/src/Model.hs index 703b78d71..1e1ecf062 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -32,10 +32,11 @@ import Data.Binary (Binary) share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] $(persistDirectoryWith lowerCaseSettings "models") --- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only -deriving instance Eq (Unique Course) -deriving instance Eq (Unique Sheet) -deriving instance Eq (Unique Tutorial) +-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code +deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName +deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet +deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial +deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial -- Primary keys mentioned in dbtable row-keys must be Binary -- Automatically generated (i.e. numeric) ids are already taken care of diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 28ecff845..0791bb218 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -86,7 +86,11 @@ import qualified Data.Binary as Binary import Time.Types (WeekDay(..)) import Data.Time.LocalTime (LocalTime, TimeOfDay) - + +import Data.Semigroup (Min(..)) +import Control.Monad.Trans.Writer (execWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -353,7 +357,7 @@ classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth - + data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) @@ -876,11 +880,11 @@ derivePersistFieldJSON ''LecturerType instance Hashable LecturerType - + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece } ''WeekDay - + data OccurenceSchedule = ScheduleWeekly { scheduleDayOfWeek :: WeekDay , scheduleStart :: TimeOfDay @@ -922,6 +926,55 @@ deriveJSON defaultOptions derivePersistFieldJSON ''Occurences +data HealthReport = HealthReport + { healthMatchingClusterConfig :: Bool + -- ^ Is the database-stored configuration we're running under still up to date? + , healthHTTPReachable :: Maybe Bool + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + -- + -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings + , healthLDAPAdmins :: Maybe Rational + -- ^ Proportion of school admins that could be found in LDAP + -- + -- Is `Nothing` if LDAP is not configured or no users are school admins + , healthSMTPConnect :: Maybe Bool + -- ^ Can we connect to the SMTP server and say @NOOP@? + , healthWidgetMemcached :: Maybe Bool + -- ^ Can we store values in memcached and retrieve them via HTTP? + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''HealthReport + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +classifyHealthReport :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point + unless healthMatchingClusterConfig . tell $ Min HealthFailure + unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure + unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure + unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure + unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure + + -- Type synonyms type Email = Text @@ -931,10 +984,12 @@ type SchoolShorthand = CI Text type CourseName = CI Text type CourseShorthand = CI Text type SheetName = CI Text +type MaterialName = CI Text type UserEmail = CI Email type TutorialName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID +type ClusterId = UUID type TokenId = UUID type TermCandidateIncidence = UUID diff --git a/src/Settings.hs b/src/Settings.hs index 085ec469a..d9798caea 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -48,9 +48,6 @@ import qualified Ldap.Client as Ldap import Utils hiding (MessageStatus(..)) import Control.Lens -import Data.Maybe (fromJust) -import qualified Data.Char as Char - import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) import qualified Network.Socket as HaskellNet (PortNumber(..), HostName) import qualified Network @@ -111,6 +108,10 @@ data AppSettings = AppSettings , appMaximumContentLength :: Maybe Word64 , appJwtExpiration :: Maybe NominalDiffTime , appJwtEncoding :: JwtEncoding + + , appHealthCheckInterval :: NominalDiffTime + , appHealthCheckHTTP :: Bool + , appHealthCheckDelayNotify :: Bool , appInitialLogSettings :: LogSettings @@ -278,7 +279,7 @@ deriveFromJSON deriveJSON defaultOptions - { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" + { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue } ''LogLevel @@ -378,6 +379,10 @@ instance FromJSON AppSettings where appJwtExpiration <- o .:? "jwt-expiration" appJwtEncoding <- o .: "jwt-encoding" + appHealthCheckInterval <- o .: "health-check-interval" + appHealthCheckHTTP <- o .: "health-check-http" + appHealthCheckDelayNotify <- o .: "health-check-delay-notify" + appSessionTimeout <- o .: "session-timeout" appMaximumContentLength <- o .: "maximum-content-length" diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index 872d901b7..037c9d967 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -36,12 +36,16 @@ import qualified Jose.Jwa as Jose import qualified Jose.Jwk as Jose import qualified Jose.Jwt as Jose +import Data.UUID (UUID) +import Control.Monad.Random.Class (MonadRandom(..)) + data ClusterSettingsKey = ClusterCryptoIDKey | ClusterClientSessionKey | ClusterSecretBoxKey | ClusterJSONWebKeySet + | ClusterId deriving (Eq, Ord, Enum, Bounded, Show, Read) instance Universe ClusterSettingsKey @@ -134,3 +138,9 @@ instance ClusterSetting 'ClusterJSONWebKeySet where jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256) return $ Jose.JwkSet [jwkSig] knownClusterSetting _ = ClusterJSONWebKeySet + + +instance ClusterSetting 'ClusterId where + type ClusterSettingValue 'ClusterId = UUID + initClusterSetting _ = liftIO getRandom + knownClusterSetting _ = ClusterId diff --git a/src/Utils.hs b/src/Utils.hs index a5939a40b..39dbf3126 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -17,6 +17,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Utils.DB as Utils import Utils.TH as Utils @@ -72,6 +73,10 @@ import Data.Ratio ((%)) import qualified Data.Binary as Binary +import Network.Wai (requestMethod) + +import Data.Time.Clock + {-# ANN choice ("HLint: ignore Use asum" :: String) #-} @@ -152,6 +157,10 @@ isNew :: Bool -> Markup isNew True = [shamlet||] -- was exclamation isNew False = mempty +boolSymbol :: Bool -> Markup +boolSymbol True = [shamlet||] +boolSymbol False = [shamlet||] + --------------------- -- Text and String -- @@ -159,12 +168,18 @@ isNew False = mempty -- DEPRECATED: use hasTickmark instead; -- maybe reinstate if needed for @bewertung.txt@ files - -- tickmark :: IsString a => a -- tickmark = fromString "✔" +-- | Convert text as it is to Html, may prevent ambiguous types +-- This function definition is mainly for documentation purposes text2Html :: Text -> Html -text2Html = toHtml -- prevents ambiguous types +text2Html = toHtml + +-- | Convert text as it is to Message, may prevent ambiguous types +-- This function definition is mainly for documentation purposes +text2message :: Text -> SomeMessage site +text2message = SomeMessage toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => a -> WidgetT site m () @@ -269,6 +284,17 @@ notUsedT = notUsed +------------- +-- Numeric -- +------------- + +-- | round n to nearest multiple of m +roundToNearestMultiple :: Int -> Int -> Int +roundToNearestMultiple m n = (n `div` m + 1) * m + + + + ------------ -- Monoid -- ------------ @@ -394,6 +420,12 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing +-- MOVED TO UTILS.DB due to cyclic dependency +-- Swap 'Nothing' for 'Just' and vice versa +-- flipMaybe :: b -> Maybe b -> Maybe b +-- flipMaybe x Nothing = Just x +-- flipMaybe _ (Just _) = Nothing + maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y @@ -501,7 +533,7 @@ maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b maybeTExceptT err act = maybeExceptT err $ runMaybeT act - + maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act @@ -562,7 +594,7 @@ ifM c m m' = ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c --- | Monadic boolean function, copied from Andreas Abel's utility function +-- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) or2M ma = ifM ma (return True) @@ -571,6 +603,7 @@ andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool andM = Fold.foldr and2M (return True) orM = Fold.foldr or2M (return False) +-- | Short-circuiting monady any allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool allM xs f = andM $ fmap f xs anyM xs f = orM $ fmap f xs @@ -651,7 +684,7 @@ takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) -- Custom HTTP Request-Headers -- --------------------------------- -data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit +data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe CustomHeader @@ -659,7 +692,7 @@ instance Finite CustomHeader nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel) lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result) -lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) +lookupCustomHeader ident = (=<<) (fromPathPiece <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) @@ -758,3 +791,27 @@ cachedHere :: Q Exp cachedHere = do loc <- location [e| cachedBy (toStrict $ Binary.encode loc) |] + +hashToText :: Hashable a => a -> Text +hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash + +setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m () +setEtagHashable = setEtag . hashToText +setWeakEtagHashable = setEtag . hashToText + +setLastModified :: (MonadHandler m, MonadLogger m) => UTCTime -> m () +setLastModified lastModified = do + rMethod <- requestMethod <$> waiRequest + + when (rMethod `elem` safeMethods) $ do + ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since" + $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince) + when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince) + notModified + + addHeader "Last-Modified" $ formatRFC1123 lastModified + where + precision :: NominalDiffTime + precision = 1 + + safeMethods = [ methodGet, methodHead, methodOptions ] diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 9700dd88f..b6e7b9950 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -10,8 +10,18 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here -emptyOrIn :: PersistField typ => - E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) + +-- | Swap 'Nothing' for 'Just' and vice versa +-- This belongs into Module 'Utils' but we have a weird cyclic +-- dependency +flipMaybe :: b -> Maybe a -> Maybe b +flipMaybe x Nothing = Just x +flipMaybe _ (Just _) = Nothing + + + +emptyOrIn :: PersistField typ + => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) emptyOrIn criterion testSet | Set.null testSet = E.val True | otherwise = criterion `E.in_` E.valList (Set.toList testSet) @@ -20,33 +30,44 @@ entities2map :: PersistEntity record => [Entity record] -> Map (Key record) reco entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) - => Unique record -> ReaderT backend m (Maybe (Key record)) + => Unique record -> ReaderT backend m (Maybe (Key record)) getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) - => Unique record -> ReaderT backend m (Key record) + => Unique record -> ReaderT backend m (Key record) getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record! existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) - => Unique record -> ReaderT backend m Bool + => Unique record -> ReaderT backend m Bool existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m) - => Key record -> ReaderT backend m Bool + => Key record -> ReaderT backend m Bool existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend ) - => Unique record -> [Update record] -> ReaderT backend m () + => Unique record -> [Update record] -> ReaderT backend m () updateBy uniq updates = do key <- getKeyBy uniq for_ key $ flip update updates -myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway) - :: (MonadIO m - ,Eq (Unique record) - ,PersistRecordBackend record backend - ,PersistUniqueWrite backend) - => Key record -> record -> ReaderT backend m (Maybe (Unique record)) +-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible, +-- and 'Just key' for the successfully replaced record +uniqueReplace :: ( MonadIO m + , Eq (Unique record) + , PersistRecordBackend record backend + , PersistUniqueWrite backend + ) + => Key record -> record -> ReaderT backend m (Maybe (Key record)) +uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew + +-- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq record which is not needed anyway) +myReplaceUnique :: ( MonadIO m + , Eq (Unique record) + , PersistRecordBackend record backend + , PersistUniqueWrite backend + ) + => Key record -> record -> ReaderT backend m (Maybe (Unique record)) myReplaceUnique key datumNew = getJust key >>= replaceOriginal where uniqueKeysNew = persistUniqueKeys datumNew @@ -59,12 +80,12 @@ myReplaceUnique key datumNew = getJust key >>= replaceOriginal changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original -checkUniqueKeys - :: (MonadIO m - ,PersistEntity record - ,PersistUniqueRead backend - ,PersistRecordBackend record backend) - => [Unique record] -> ReaderT backend m (Maybe (Unique record)) +checkUniqueKeys :: ( MonadIO m + , PersistEntity record + , PersistUniqueRead backend + , PersistRecordBackend record backend + ) + => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1fa6de74f..d4d0ba97e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -169,6 +169,7 @@ data FormIdentifier = FIDcourse | FIDcourseRegister | FIDsheet + | FIDmaterial | FIDsubmission | FIDsettings | FIDcorrectors @@ -574,7 +575,7 @@ formFailure errs' = do mr <- getMessageRender return . FormFailure $ map mr errs' - +-- | Turns errors into alerts, ignores missing forms and applies processing function formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x diff --git a/static/js/utils/form.js b/static/js/utils/form.js index 54c3a430f..4c77f8621 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -106,11 +106,15 @@ return init(); }; - formUtilities.push({ - name: REACTIVE_SUBMIT_BUTTON_UTIL_NAME, - selector: REACTIVE_SUBMIT_BUTTON_UTIL_SELECTOR, - setup: reactiveSubmitButtonUtil, - }); + // skipping reactiveButtonUtil (for now) + // the button did not properly re-enable after filling out a form for some safari users. + // if maybe in the future there is going to be a proper way of (asynchronously) and + // meaningfully validating forms this can be re-activated by commenting in the next few lines + // formUtilities.push({ + // name: REACTIVE_SUBMIT_BUTTON_UTIL_NAME, + // selector: REACTIVE_SUBMIT_BUTTON_UTIL_SELECTOR, + // setup: reactiveSubmitButtonUtil, + // }); /** * diff --git a/static/js/utils/massInput.js b/static/js/utils/massInput.js new file mode 100644 index 000000000..8e15a4f79 --- /dev/null +++ b/static/js/utils/massInput.js @@ -0,0 +1,224 @@ +(function() { + 'use strict'; + + /** + * + * Mass Input Utility + * allows form shapes to be manipulated asynchronously: + * will asynchronously submit the containing form and replace the contents + * of the mass input element with the one from the BE response + * The utility will only trigger an AJAX request if the mass input element has + * an active/focused element whilst the form is being submitted. + * + * Attribute: uw-mass-input + * + * Example usage: + *
+ * + *
+ * + *