Steffen Jost
parent
b694a093d5
commit
d23e222fd0
@ -119,5 +119,6 @@ user-defaults:
|
||||
date-format: "%d.%m.%Y"
|
||||
time-format: "%R"
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
|
||||
@ -596,7 +596,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
|
||||
|
||||
NoTableContent: Kein Tabelleninhalt
|
||||
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
|
||||
AdminUserHeading: Benutzeradministration
|
||||
@ -622,6 +622,8 @@ DateFormat: Datumsformat
|
||||
TimeFormat: Uhrzeitformat
|
||||
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).
|
||||
WarningDays: Fristen-Vorschau
|
||||
WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden?
|
||||
NotificationSettings: Erwünschte Benachrichtigungen
|
||||
FormNotifications: Benachrichtigungen
|
||||
FormBehaviour: Verhalten
|
||||
@ -1484,7 +1486,7 @@ AllocationStaffRegister: Eintragung der Kurse
|
||||
AllocationRegisterFrom: Bewerbung ab
|
||||
AllocationRegister: Bewerbung
|
||||
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
|
||||
AllocationStaffAllocation: Bewerbungsbewertung
|
||||
AllocationProcess: Platzvergabe
|
||||
|
||||
13
models/users
13
models/users
@ -11,7 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
ident (CI Text) -- Case-insensitive user-identifier
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
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,...)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined
|
||||
warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
|
||||
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
|
||||
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
|
||||
user UserId
|
||||
school SchoolId
|
||||
|
||||
@ -6,17 +6,27 @@ module Data.Time.Clock.Instances
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Time.Clock
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Calendar.Instances ()
|
||||
|
||||
|
||||
instance Hashable DiffTime where
|
||||
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
|
||||
instance Hashable UTCTime
|
||||
@ -25,5 +35,5 @@ instance Hashable UTCTime
|
||||
instance Binary DiffTime where
|
||||
get = fromRational <$> Binary.get
|
||||
put = Binary.put . toRational
|
||||
|
||||
|
||||
instance Binary UTCTime
|
||||
|
||||
@ -1116,7 +1116,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
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.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
|
||||
|
||||
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
@ -3058,6 +3058,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
|
||||
@ -129,131 +129,133 @@ homeUpcomingSheets uid = do
|
||||
homeUpcomingExams :: UserId -> Widget
|
||||
homeUpcomingExams uid = do
|
||||
now <- liftIO getCurrentTime
|
||||
let fortnight = addWeeks 2 now
|
||||
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
||||
examDBTable = DBTable{..}
|
||||
where
|
||||
-- for ease of refactoring:
|
||||
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
lensCourse = _1
|
||||
lensExam = _2
|
||||
lensRegister = _3 . _Just
|
||||
lensOccurrence = _4 . _Just
|
||||
((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
|
||||
User {userWarningDays} <- get404 uid
|
||||
let fortnight = addUTCTime userWarningDays now
|
||||
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
||||
examDBTable = DBTable{..}
|
||||
where
|
||||
-- for ease of refactoring:
|
||||
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
lensCourse = _1
|
||||
lensExam = _2
|
||||
lensRegister = _3 . _Just
|
||||
lensOccurrence = _4 . _Just
|
||||
|
||||
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.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
|
||||
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ E.exists $ E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
|
||||
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
|
||||
E.&&. E.isNothing (register E.?. ExamRegistrationId)
|
||||
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
|
||||
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
|
||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
||||
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||
earliestOccurrence = E.sub_select $ E.from $ \occ -> do
|
||||
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
||||
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
||||
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
||||
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
|
||||
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
|
||||
-- E.&&. earliestOccurrence E.>=. E.just (E.val now)
|
||||
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
|
||||
return (course, exam, register, occurrence)
|
||||
dbtRowKey = queryExam >>> (E.^. ExamId)
|
||||
dbtProj r@DBRow{ dbrOutput } = do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
|
||||
return r
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
msgCell courseTerm
|
||||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
msgCell courseSchool
|
||||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
||||
-- continue here
|
||||
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
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-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
|
||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
|
||||
| Entity _ Exam{..} <- view lensExam dbrOutput
|
||||
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
|
||||
| otherwise -> mempty
|
||||
{- 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.
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||
let Entity eId Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm examRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
||||
, formEncoding = examRegisterEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||||
| otherwise -> return mempty
|
||||
-}
|
||||
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||
let isRegistered = has lensRegister dbrOutput
|
||||
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
||||
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
||||
| otherwise -> return [whamlet|_{label}|]
|
||||
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
|
||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||
-> textCell examOccurrenceRoom
|
||||
| otherwise -> mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
||||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||||
E.exists $ E.from $ \registration -> do
|
||||
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
))
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exams"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
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.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
|
||||
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ E.exists $ E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
|
||||
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
|
||||
E.&&. E.isNothing (register E.?. ExamRegistrationId)
|
||||
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
|
||||
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
|
||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
||||
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||
earliestOccurrence = E.sub_select $ E.from $ \occ -> do
|
||||
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
||||
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
||||
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
||||
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
|
||||
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
|
||||
-- E.&&. earliestOccurrence E.>=. E.just (E.val now)
|
||||
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
|
||||
return (course, exam, register, occurrence)
|
||||
dbtRowKey = queryExam >>> (E.^. ExamId)
|
||||
dbtProj r@DBRow{ dbrOutput } = do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
|
||||
return r
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
msgCell courseTerm
|
||||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
msgCell courseSchool
|
||||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
||||
-- continue here
|
||||
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
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-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
|
||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
|
||||
| Entity _ Exam{..} <- view lensExam dbrOutput
|
||||
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
|
||||
| otherwise -> mempty
|
||||
{- 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.
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||
let Entity eId Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm examRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
||||
, formEncoding = examRegisterEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||||
| otherwise -> return mempty
|
||||
-}
|
||||
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||||
Entity _ Course{..} = view lensCourse dbrOutput
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||||
let isRegistered = has lensRegister dbrOutput
|
||||
label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
||||
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
||||
| otherwise -> return [whamlet|_{label}|]
|
||||
, sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
|
||||
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
||||
-> textCell examOccurrenceRoom
|
||||
| otherwise -> mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
||||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||||
E.exists $ E.from $ \registration -> do
|
||||
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
))
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exams"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
examDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
examDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
|
||||
(Any hasExams, examTable) <- liftHandlerT . runDB $ dbTable examDBTableValidator examDBTable
|
||||
(, userWarningDays) <$> dbTable examDBTableValidator examDBTable
|
||||
|
||||
$(widgetFile "home/upcomingExams")
|
||||
|
||||
|
||||
@ -24,6 +24,7 @@ data SettingsForm = SettingsForm
|
||||
, stgDate :: DateTimeFormat
|
||||
, stgTime :: DateTimeFormat
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgNotificationSettings :: NotificationSettings
|
||||
}
|
||||
|
||||
@ -50,6 +51,9 @@ makeSettingForm template html = do
|
||||
<*> apopt checkBoxField (fslI MsgDownloadFiles
|
||||
& setTooltip MsgDownloadFilesTip
|
||||
) (stgDownloadFiles <$> template)
|
||||
<*> areq daysField (fslI MsgWarningDays
|
||||
& setTooltip MsgWarningDaysTip
|
||||
) (stgWarningDays <$> template)
|
||||
<* aformSection MsgFormNotifications
|
||||
<*> notificationForm (stgNotificationSettings <$> template)
|
||||
return (result, widget) -- no validation required here
|
||||
@ -181,6 +185,7 @@ postProfileR = do
|
||||
, stgTime = userTimeFormat
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgNotificationSettings = userNotificationSettings
|
||||
, stgWarningDays = userWarningDays
|
||||
}
|
||||
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
||||
|
||||
|
||||
@ -112,7 +112,7 @@ data AppSettings = AppSettings
|
||||
, appMaximumContentLength :: Maybe Word64
|
||||
, appJwtExpiration :: Maybe NominalDiffTime
|
||||
, appJwtEncoding :: JwtEncoding
|
||||
|
||||
|
||||
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
|
||||
, appHealthCheckDelayNotify :: Bool
|
||||
, appHealthCheckHTTP :: Bool
|
||||
@ -159,8 +159,9 @@ data UserDefaultConf = UserDefaultConf
|
||||
, userDefaultMaxFavourites :: Int
|
||||
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
|
||||
, userDefaultDownloadFiles :: Bool
|
||||
, userDefaultWarningDays :: NominalDiffTime
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
data PWHashConf = PWHashConf
|
||||
{ pwHashAlgorithm :: PWHashAlgorithm
|
||||
, pwHashStrength :: Int
|
||||
@ -189,7 +190,7 @@ data LdapConf = LdapConf
|
||||
, ldapSearchTimeout :: Int32
|
||||
, ldapPool :: ResourcePoolConf
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
data SmtpConf = SmtpConf
|
||||
{ smtpHost :: HaskellNet.HostName
|
||||
, smtpPort :: HaskellNet.PortNumber
|
||||
@ -223,7 +224,7 @@ instance FromJSON WidgetMemcachedConf where
|
||||
connectionIdleTime <- o .: "timeout"
|
||||
widgetMemcachedBaseUrl <- o .: "base-url"
|
||||
widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
|
||||
|
||||
|
||||
return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
|
||||
|
||||
data ResourcePoolConf = ResourcePoolConf
|
||||
@ -251,7 +252,7 @@ deriveJSON defaultOptions
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''LogSettings
|
||||
|
||||
|
||||
deriveFromJSON defaultOptions ''Ldap.Scope
|
||||
deriveFromJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
|
||||
@ -41,6 +41,7 @@ import Data.UUID
|
||||
import Data.Ratio ((%))
|
||||
import Data.Fixed
|
||||
import Data.Scientific
|
||||
import Data.Time.Clock (NominalDiffTime, nominalDay)
|
||||
|
||||
import Utils
|
||||
-- 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
|
||||
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
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Exception SecretJSONFieldException
|
||||
|
||||
@ -4,4 +4,4 @@ $newline never
|
||||
$if hasExams
|
||||
^{examTable}
|
||||
$else
|
||||
_{MsgNoUpcomingExams}
|
||||
_{MsgNoUpcomingExams (formatDiffDays warningDays)}
|
||||
|
||||
@ -103,6 +103,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["en"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
@ -123,6 +124,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
@ -143,6 +145,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
@ -163,6 +166,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
@ -183,6 +187,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
@ -203,6 +208,7 @@ fillDb = do
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
|
||||
@ -125,6 +125,7 @@ createUser adjUser = do
|
||||
userDateFormat = userDefaultDateFormat
|
||||
userTimeFormat = userDefaultTimeFormat
|
||||
userDownloadFiles = userDefaultDownloadFiles
|
||||
userWarningDays = userDefaultWarningDays
|
||||
userMailLanguages = def
|
||||
userNotificationSettings = def
|
||||
runDB . insertEntity $ adjUser User{..}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user