fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(home): allow users to define exam warning time

Browse Source 
Closes #445
This commit is contained in:
Steffen Jost 2019-08-22 17:52:13 +02:00
parent b694a093d5
commit d23e222fd0
12 changed files with 177 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

@ -119,5 +119,6 @@ user-defaults:
date-format: "%d.%m.%Y" date-format: "%d.%m.%Y"
time-format: "%R" time-format: "%R"
download-files: false download-files: false
warning-days: 1209600
instance-id: "_env:INSTANCE_ID:instance" instance-id: "_env:INSTANCE_ID:instance"

6
messages/uniworx/de.msg
View File

@ -596,7 +596,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
NoTableContent: Kein Tabelleninhalt NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Prüfung mit offener Registrierung in Ihren Kursen NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfung oder ablaufende Prüfungsanmeldungen in Ihren Kursen
AdminHeading: Administration AdminHeading: Administration
AdminUserHeading: Benutzeradministration AdminUserHeading: Benutzeradministration
@ -622,6 +622,8 @@ DateFormat: Datumsformat
TimeFormat: Uhrzeitformat TimeFormat: Uhrzeitformat
DownloadFiles: Dateien automatisch herunterladen DownloadFiles: Dateien automatisch herunterladen
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
WarningDays: Fristen-Vorschau
WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
NotificationSettings: Erwünschte Benachrichtigungen NotificationSettings: Erwünschte Benachrichtigungen
FormNotifications: Benachrichtigungen FormNotifications: Benachrichtigungen
FormBehaviour: Verhalten FormBehaviour: Verhalten
@ -1484,7 +1486,7 @@ AllocationStaffRegister: Eintragung der Kurse
AllocationRegisterFrom: Bewerbung ab AllocationRegisterFrom: Bewerbung ab
AllocationRegister: Bewerbung AllocationRegister: Bewerbung
AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen. AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen.
AllocationRegisterOpensIn opens@Text: Die Zentralanmeldung öffnet voraussichtlich in #{opens} AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime}
AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab
AllocationStaffAllocation: Bewerbungsbewertung AllocationStaffAllocation: Bewerbungsbewertung
AllocationProcess: Platzvergabe AllocationProcess: Platzvergabe

13
models/users
View File

@ -11,7 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
ident (CI Text) -- Case-insensitive user-identifier ident (CI Text) -- Case-insensitive user-identifier
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date lastAuthentication UTCTime Maybe -- last login date
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
email (CI Text) -- Case-insensitive eMail address email (CI Text) -- Case-insensitive eMail address
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
@ -23,12 +23,13 @@ User json -- Each Uni2work user has a corresponding row in this table; create
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined
dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined
timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined
downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
UniqueEmail email -- Column 'email' can be used as a row-key in this table UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory UniqueEmail email -- Column 'email' can be used as a row-key in this table
deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory
UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user
user UserId user UserId
school SchoolId school SchoolId

14
src/Data/Time/Clock/Instances.hs
View File

@ -6,17 +6,27 @@ module Data.Time.Clock.Instances
import ClassyPrelude import ClassyPrelude
import Data.Time.Clock import Database.Persist.Sql
import Data.Proxy
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import Data.Time.Clock
import Data.Time.Calendar.Instances () import Data.Time.Calendar.Instances ()
instance Hashable DiffTime where instance Hashable DiffTime where
hashWithSalt s = hashWithSalt s . toRational hashWithSalt s = hashWithSalt s . toRational
instance PersistField NominalDiffTime where
toPersistValue = toPersistValue . toRational
fromPersistValue = fmap fromRational . fromPersistValue
instance PersistFieldSql NominalDiffTime where
sqlType _ = sqlType (Proxy @Rational)
deriving instance Generic UTCTime deriving instance Generic UTCTime
instance Hashable UTCTime instance Hashable UTCTime
@ -25,5 +35,5 @@ instance Hashable UTCTime
instance Binary DiffTime where instance Binary DiffTime where
get = fromRational <$> Binary.get get = fromRational <$> Binary.get
put = Binary.put . toRational put = Binary.put . toRational
instance Binary UTCTime instance Binary UTCTime

3
src/Foundation.hs
View File

@ -1116,7 +1116,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom) E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo) E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
unauthorizedI MsgUnauthorizedParticipant unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
@ -3058,6 +3058,7 @@ upsertCampusUser ldapData Creds{..} = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userNotificationSettings = def , userNotificationSettings = def
, userMailLanguages = def , userMailLanguages = def
, userTokensIssuedAfter = Nothing , userTokensIssuedAfter = Nothing

246
src/Handler/Home.hs
View File

@ -129,131 +129,133 @@ homeUpcomingSheets uid = do
homeUpcomingExams :: UserId -> Widget homeUpcomingExams :: UserId -> Widget
homeUpcomingExams uid = do homeUpcomingExams uid = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let fortnight = addWeeks 2 now ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
let -- code copied and slightly adapted from Handler.Course.getCShowR: User {userWarningDays} <- get404 uid
examDBTable = DBTable{..} let fortnight = addUTCTime userWarningDays now
where let -- code copied and slightly adapted from Handler.Course.getCShowR:
-- for ease of refactoring: examDBTable = DBTable{..}
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) where
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) -- for ease of refactoring:
lensCourse = _1 queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
lensExam = _2 queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
lensRegister = _3 . _Just lensCourse = _1
lensOccurrence = _4 . _Just lensExam = _2
lensRegister = _3 . _Just
lensOccurrence = _4 . _Just
dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ E.exists $ E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
E.&&. E.isNothing (register E.?. ExamRegistrationId) E.&&. E.isNothing (register E.?. ExamRegistrationId)
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
E.&&. E.isJust (register E.?. ExamRegistrationId) E.&&. E.isJust (register E.?. ExamRegistrationId)
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
E.&&. E.isJust (register E.?. ExamRegistrationId) E.&&. E.isJust (register E.?. ExamRegistrationId)
earliestOccurrence = E.sub_select $ E.from $ \occ -> do earliestOccurrence = E.sub_select $ E.from $ \occ -> do
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
return $ E.min_ $ occ E.^. ExamOccurrenceStart return $ E.min_ $ occ E.^. ExamOccurrenceStart
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
-- E.&&. earliestOccurrence E.>=. E.just (E.val now) -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
return (course, exam, register, occurrence) return (course, exam, register, occurrence)
dbtRowKey = queryExam >>> (E.^. ExamId) dbtRowKey = queryExam >>> (E.^. ExamId)
dbtProj r@DBRow{ dbrOutput } = do dbtProj r@DBRow{ dbrOutput } = do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
return r return r
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
msgCell courseTerm msgCell courseTerm
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
msgCell courseSchool msgCell courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
-- continue here -- continue here
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } -> , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
| Entity _ Exam{..} <- view lensExam dbrOutput | Entity _ Exam{..} <- view lensExam dbrOutput
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
| otherwise -> mempty | otherwise -> mempty
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
let Entity eId Exam{..} = view lensExam dbrOutput let Entity eId Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
isRegistered <- existsBy $ UniqueExamRegistration eId uid isRegistered <- existsBy $ UniqueExamRegistration eId uid
if if
| mayRegister -> do | mayRegister -> do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
, formEncoding = examRegisterEnctype , formEncoding = examRegisterEnctype
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
} }
| isRegistered -> return [whamlet|_{MsgExamRegistered}|] | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
| otherwise -> return mempty | otherwise -> return mempty
-} -}
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
let isRegistered = has lensRegister dbrOutput let isRegistered = has lensRegister dbrOutput
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|] | otherwise -> return [whamlet|_{label}|]
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
-> textCell examOccurrenceRoom -> textCell examOccurrenceRoom
| otherwise -> mempty | otherwise -> mempty
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
, ("name", SortColumn $ queryExam >>> (E.^. ExamName )) , ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) , ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
, ("registered", SortColumn $ queryExam >>> (\exam -> , ("registered", SortColumn $ queryExam >>> (\exam ->
E.exists $ E.from $ \registration -> do E.exists $ E.from $ \registration -> do
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)) ))
] ]
dbtFilter = Map.empty dbtFilter = Map.empty
dbtFilterUI = const mempty dbtFilterUI = const mempty
dbtStyle = def dbtStyle = def
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "exams" dbtIdent = "exams"
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
examDBTableValidator = def examDBTableValidator = def
& defaultSorting [SortAscBy "time"] & defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- liftHandlerT . runDB $ dbTable examDBTableValidator examDBTable (, userWarningDays) <$> dbTable examDBTableValidator examDBTable
$(widgetFile "home/upcomingExams") $(widgetFile "home/upcomingExams")

5
src/Handler/Profile.hs
View File

@ -24,6 +24,7 @@ data SettingsForm = SettingsForm
, stgDate :: DateTimeFormat , stgDate :: DateTimeFormat
, stgTime :: DateTimeFormat , stgTime :: DateTimeFormat
, stgDownloadFiles :: Bool , stgDownloadFiles :: Bool
, stgWarningDays :: NominalDiffTime
, stgNotificationSettings :: NotificationSettings , stgNotificationSettings :: NotificationSettings
} }
@ -50,6 +51,9 @@ makeSettingForm template html = do
<*> apopt checkBoxField (fslI MsgDownloadFiles <*> apopt checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip & setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template) ) (stgDownloadFiles <$> template)
<*> areq daysField (fslI MsgWarningDays
& setTooltip MsgWarningDaysTip
) (stgWarningDays <$> template)
<* aformSection MsgFormNotifications <* aformSection MsgFormNotifications
<*> notificationForm (stgNotificationSettings <$> template) <*> notificationForm (stgNotificationSettings <$> template)
return (result, widget) -- no validation required here return (result, widget) -- no validation required here
@ -181,6 +185,7 @@ postProfileR = do
, stgTime = userTimeFormat , stgTime = userTimeFormat
, stgDownloadFiles = userDownloadFiles , stgDownloadFiles = userDownloadFiles
, stgNotificationSettings = userNotificationSettings , stgNotificationSettings = userNotificationSettings
, stgWarningDays = userWarningDays
} }
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate

11
src/Settings.hs
View File

@ -112,7 +112,7 @@ data AppSettings = AppSettings
, appMaximumContentLength :: Maybe Word64 , appMaximumContentLength :: Maybe Word64
, appJwtExpiration :: Maybe NominalDiffTime , appJwtExpiration :: Maybe NominalDiffTime
, appJwtEncoding :: JwtEncoding , appJwtEncoding :: JwtEncoding
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
, appHealthCheckDelayNotify :: Bool , appHealthCheckDelayNotify :: Bool
, appHealthCheckHTTP :: Bool , appHealthCheckHTTP :: Bool
@ -159,8 +159,9 @@ data UserDefaultConf = UserDefaultConf
, userDefaultMaxFavourites :: Int , userDefaultMaxFavourites :: Int
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool , userDefaultDownloadFiles :: Bool
, userDefaultWarningDays :: NominalDiffTime
} deriving (Show) } deriving (Show)
data PWHashConf = PWHashConf data PWHashConf = PWHashConf
{ pwHashAlgorithm :: PWHashAlgorithm { pwHashAlgorithm :: PWHashAlgorithm
, pwHashStrength :: Int , pwHashStrength :: Int
@ -189,7 +190,7 @@ data LdapConf = LdapConf
, ldapSearchTimeout :: Int32 , ldapSearchTimeout :: Int32
, ldapPool :: ResourcePoolConf , ldapPool :: ResourcePoolConf
} deriving (Show) } deriving (Show)
data SmtpConf = SmtpConf data SmtpConf = SmtpConf
{ smtpHost :: HaskellNet.HostName { smtpHost :: HaskellNet.HostName
, smtpPort :: HaskellNet.PortNumber , smtpPort :: HaskellNet.PortNumber
@ -223,7 +224,7 @@ instance FromJSON WidgetMemcachedConf where
connectionIdleTime <- o .: "timeout" connectionIdleTime <- o .: "timeout"
widgetMemcachedBaseUrl <- o .: "base-url" widgetMemcachedBaseUrl <- o .: "base-url"
widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration" widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. } return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
data ResourcePoolConf = ResourcePoolConf data ResourcePoolConf = ResourcePoolConf
@ -251,7 +252,7 @@ deriveJSON defaultOptions
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
} ''LogSettings } ''LogSettings
deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions ''Ldap.Scope
deriveFromJSON defaultOptions deriveFromJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2 { fieldLabelModifier = camelToPathPiece' 2

8
src/Utils/Form.hs
View File

@ -41,6 +41,7 @@ import Data.UUID
import Data.Ratio ((%)) import Data.Ratio ((%))
import Data.Fixed import Data.Fixed
import Data.Scientific import Data.Scientific
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Utils import Utils
-- import Utils.Message -- import Utils.Message
@ -565,6 +566,13 @@ intMinMaxField lower upper = intF{ fieldView=newView }
newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq
newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ] newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]
daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
daysField = convertField toDays fromDays fractionalField
where
toDays = (/ nominalDay)
fromDays = (* nominalDay)
data SecretJSONFieldException = SecretJSONFieldDecryptFailure data SecretJSONFieldException = SecretJSONFieldDecryptFailure
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Exception SecretJSONFieldException instance Exception SecretJSONFieldException

2
templates/home/upcomingExams.hamlet
View File

@ -4,4 +4,4 @@ $newline never
$if hasExams $if hasExams
^{examTable} ^{examTable}
$else $else
_{MsgNoUpcomingExams} _{MsgNoUpcomingExams (formatDiffDays warningDays)}

6
test/Database.hs
View File

@ -103,6 +103,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["en"] , userMailLanguages = MailLanguages ["en"]
, userNotificationSettings = def , userNotificationSettings = def
} }
@ -123,6 +124,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }
@ -143,6 +145,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }
@ -163,6 +166,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }
@ -183,6 +187,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }
@ -203,6 +208,7 @@ fillDb = do
, userDateFormat = userDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles , userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userMailLanguages = MailLanguages ["de"] , userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def , userNotificationSettings = def
} }

1
test/TestImport.hs
View File

@ -125,6 +125,7 @@ createUser adjUser = do
userDateFormat = userDefaultDateFormat userDateFormat = userDefaultDateFormat
userTimeFormat = userDefaultTimeFormat userTimeFormat = userDefaultTimeFormat
userDownloadFiles = userDefaultDownloadFiles userDownloadFiles = userDefaultDownloadFiles
userWarningDays = userDefaultWarningDays
userMailLanguages = def userMailLanguages = def
userNotificationSettings = def userNotificationSettings = def
runDB . insertEntity $ adjUser User{..} runDB . insertEntity $ adjUser User{..}