Merge branch 'master' into feat/allocation-new-course-notification
This commit is contained in:
Gregor Kleen
commit
63a876fb97
@ -12,6 +12,7 @@
|
||||
- ignore: { name: "Use ***" }
|
||||
- ignore: { name: "Redundant void" }
|
||||
- ignore: { name: "Too strict maybe" }
|
||||
- ignore: { name: "Use Just" }
|
||||
|
||||
- arguments:
|
||||
- -XQuasiQuotes
|
||||
|
||||
@ -628,6 +628,11 @@ section
|
||||
&.notification--broad
|
||||
max-width: none
|
||||
|
||||
&:first-child
|
||||
margin-top: 0
|
||||
&:last-child
|
||||
margin-bottom: 0
|
||||
|
||||
.form-section-notification
|
||||
display: grid
|
||||
grid-template-columns: 1fr 3fr
|
||||
@ -1100,9 +1105,8 @@ th, td
|
||||
pointer-events: none
|
||||
|
||||
#changelog
|
||||
font-size: 14px
|
||||
white-space: pre-wrap
|
||||
font-family: var(--font-monospace)
|
||||
max-height: 75vh
|
||||
overflow: auto
|
||||
|
||||
#gitrev
|
||||
font-size: 12px
|
||||
|
||||
@ -1840,6 +1840,39 @@ ExamFormOccurrences: Prüfungstermine/Räume
|
||||
ExamFormAutomaticFunctions: Automatische Funktionen
|
||||
ExamFormCorrection: Korrektur
|
||||
ExamFormParts: Teile
|
||||
ExamFormMode: Ausgestaltung der Prüfung
|
||||
|
||||
ExamModeFormNone: Keine Angabe
|
||||
ExamModeFormCustom: Benutzerdefiniert
|
||||
ExamModeFormAids: Erlaubte Hilfsmittel
|
||||
ExamModeFormOnline: Online/Offline
|
||||
ExamModeFormSynchronicity: Synchron/Asynchron
|
||||
ExamModeFormRequiredEquipment: Erforderliche Hilfsmittel
|
||||
ExamModeFormRequiredEquipmentIdentificationTip: Es wird stets ein Hinweis angezeigt, dass Teilnehmer sich ausweisen können müssen.
|
||||
|
||||
ExamShowAids: Erlaubte Hilfsmittel
|
||||
ExamShowOnline: Online/Offline
|
||||
ExamShowSynchronicity: Synchron/Asynchron
|
||||
ExamShowRequiredEquipment: Erforderliche Hilfsmittel
|
||||
ExamShowRequiredEquipmentNoneSet: Keine Angabe durch die Kursverwalter
|
||||
ExamShowIdentificationRequired: Prüfungsteilnehmer müssen sich ausweisen können. Halten Sie dafür einen amtlichen Lichtbildausweis (Personalausweis, Reisepass, Aufenthaltstitel) und Ihren Studierendenausweis bereit.
|
||||
|
||||
ExamOpenBook: Open Book
|
||||
ExamClosedBook: Closed Book
|
||||
|
||||
ExamOnline: Online
|
||||
ExamOffline: Offline
|
||||
|
||||
ExamSynchronous: Synchron
|
||||
ExamAsynchronous: Asynchron
|
||||
|
||||
ExamRequiredEquipmentNone: Nichts
|
||||
ExamRequiredEquipmentPen: Stift
|
||||
ExamRequiredEquipmentPaperPen: Stift & Papier
|
||||
ExamRequiredEquipmentCalculatorPen: Stift & Taschenrechner
|
||||
ExamRequiredEquipmentCalculatorPaperPen: Stift, Papier & Taschenrechner
|
||||
ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & Mikrophon
|
||||
ExamRequiredEquipmentMicrophoneInternet: Mikrophon
|
||||
|
||||
ExamCorrectors: Korrektoren
|
||||
ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
|
||||
@ -1892,6 +1925,10 @@ ExamFinishedMustBeAfterStart: "Ergebnisse sichtbar ab" muss nach Beginn liegen
|
||||
ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Ergebnisse sichtbar ab" liegen
|
||||
ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Beginn liegen
|
||||
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
|
||||
ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Beginn" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
|
||||
ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
|
||||
ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann.
|
||||
ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten
|
||||
|
||||
ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
|
||||
ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen
|
||||
@ -2248,6 +2285,13 @@ SchoolName: Name
|
||||
SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
|
||||
SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
|
||||
SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt
|
||||
SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen
|
||||
SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozenten gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen.
|
||||
SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen
|
||||
SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozenten daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen.
|
||||
SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung
|
||||
SchoolExamRequireModeForRegistrationTip: Sollen Dozenten gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen?
|
||||
SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung
|
||||
|
||||
SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
|
||||
SchoolTitle ssh@SchoolId: Institut „#{ssh}“
|
||||
@ -2788,4 +2832,7 @@ CronMatchAsap: ASAP
|
||||
CronMatchNone: Nie
|
||||
|
||||
SystemExamOffice: Prüfungsverwaltung
|
||||
SystemFaculty: Fakultätsmitglied
|
||||
SystemFaculty: Fakultätsmitglied
|
||||
|
||||
ChangelogItemFeature: Feature
|
||||
ChangelogItemBugfix: Bugfix
|
||||
@ -1839,6 +1839,39 @@ ExamFormOccurrences: Occurrences/rooms
|
||||
ExamFormAutomaticFunctions: Automatic functions
|
||||
ExamFormCorrection: Correction
|
||||
ExamFormParts: Exam parts
|
||||
ExamFormMode: Exam design
|
||||
|
||||
ExamModeFormNone: Not specified
|
||||
ExamModeFormCustom: Custom
|
||||
ExamModeFormAids: Permitted exam aids
|
||||
ExamModeFormOnline: Online/Offline
|
||||
ExamModeFormSynchronicity: Synchronous/Asynchronous
|
||||
ExamModeFormRequiredEquipment: Required equipment
|
||||
ExamModeFormRequiredEquipmentIdentificationTip: There will always be a note informing participants that they will need photo identification.
|
||||
|
||||
ExamShowAids: Permitted exam aids
|
||||
ExamShowOnline: Online/Offline
|
||||
ExamShowSynchronicity: Synchronous/Asynchronous
|
||||
ExamShowRequiredEquipment: Required equipment
|
||||
ExamShowRequiredEquipmentNoneSet: Not specified
|
||||
ExamShowIdentificationRequired: Exam participants need to be able to identify themselves. Therefor please ensure that you have official photo identification („Personalausweis“, passport, residence permit) and your student identification at hand during the exam.
|
||||
|
||||
ExamOpenBook: Open book
|
||||
ExamClosedBook: Closed book
|
||||
|
||||
ExamOnline: Online
|
||||
ExamOffline: Offline
|
||||
|
||||
ExamSynchronous: Synchronous
|
||||
ExamAsynchronous: Asynchronous
|
||||
|
||||
ExamRequiredEquipmentNone: Nothing
|
||||
ExamRequiredEquipmentPen: Pen
|
||||
ExamRequiredEquipmentPaperPen: Pen & paper
|
||||
ExamRequiredEquipmentCalculatorPen: Pen & calculator
|
||||
ExamRequiredEquipmentCalculatorPaperPen: Pen, paper & calculator
|
||||
ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & microphone
|
||||
ExamRequiredEquipmentMicrophoneInternet: Microphone
|
||||
|
||||
ExamCorrectors: Correctors
|
||||
ExamCorrectorsTip: Correctors configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
|
||||
@ -1891,6 +1924,10 @@ ExamFinishedMustBeAfterStart: "Results visible from" must be after "start"
|
||||
ExamClosedMustBeAfterFinished: "Exam achievements registered" must be after "results visible from"
|
||||
ExamClosedMustBeAfterStart: "Exam achievements registered" must be after "start"
|
||||
ExamClosedMustBeAfterEnd: "Exam achievements registered" must be after "end"
|
||||
ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Start".
|
||||
ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to".
|
||||
ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set.
|
||||
ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged
|
||||
|
||||
ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start
|
||||
ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start
|
||||
@ -2248,6 +2285,13 @@ SchoolName: Name
|
||||
SchoolLdapOrganisations: Associated LDAP fragments
|
||||
SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry
|
||||
SchoolLdapOrganisationMissing: LDAP-fragment is required
|
||||
SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams
|
||||
SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time.
|
||||
SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams
|
||||
SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days.
|
||||
SchoolExamRequireModeForRegistration: Exam design required for registration
|
||||
SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period?
|
||||
SchoolExamDiscouragedModes: Exam designs to warn against
|
||||
|
||||
SchoolUpdated ssh: Successfully edited #{ssh}
|
||||
SchoolTitle ssh: Department „#{ssh}“
|
||||
@ -2790,3 +2834,6 @@ CronMatchNone: Never
|
||||
|
||||
SystemExamOffice: Exam office
|
||||
SystemFaculty: Faculty member
|
||||
|
||||
ChangelogItemFeature: Feature
|
||||
ChangelogItemBugfix: Bugfix
|
||||
4
models/changelog.model
Normal file
4
models/changelog.model
Normal file
@ -0,0 +1,4 @@
|
||||
ChangelogItemFirstSeen
|
||||
item ChangelogItem
|
||||
firstSeen Day
|
||||
Primary item
|
||||
@ -17,6 +17,7 @@ Exam
|
||||
publicStatistics Bool
|
||||
gradingMode ExamGradingMode
|
||||
description Html Maybe
|
||||
examMode ExamMode
|
||||
UniqueExam course name
|
||||
ExamPart
|
||||
exam ExamId
|
||||
|
||||
@ -3,6 +3,10 @@
|
||||
School json
|
||||
name (CI Text)
|
||||
shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId
|
||||
examMinimumRegisterBeforeStart NominalDiffTime Maybe
|
||||
examMinimumRegisterDuration NominalDiffTime Maybe
|
||||
examRequireModeForRegistration Bool default=false
|
||||
examDiscouragedModes ExamModeDNF
|
||||
UniqueSchool name
|
||||
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
|
||||
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
|
||||
|
||||
@ -158,6 +158,7 @@ other-extensions:
|
||||
- IncoherentInstances
|
||||
- OverloadedLists
|
||||
- UndecidableInstances
|
||||
- ApplicativeDo
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.Calendar.Instances
|
||||
@ -11,8 +10,13 @@ import Data.Time.Calendar
|
||||
|
||||
import Data.Universe
|
||||
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Type.Reflection
|
||||
|
||||
deriving newtype instance Hashable Day
|
||||
|
||||
deriving instance Lift Day
|
||||
instance Hashable Day where
|
||||
hashWithSalt s (ModifiedJulianDay jDay) = s `hashWithSalt` hash (typeRep @Day) `hashWithSalt` jDay
|
||||
|
||||
deriving instance Ord DayOfWeek
|
||||
instance Universe DayOfWeek where
|
||||
|
||||
@ -14,7 +14,10 @@ import Data.Universe.Helpers (interleave)
|
||||
|
||||
import Control.Monad (unless)
|
||||
|
||||
import Data.List (elemIndex)
|
||||
import Data.List (elemIndex, nub)
|
||||
|
||||
import Control.Lens hiding (universe)
|
||||
import Data.Generics.Product.Types
|
||||
|
||||
|
||||
-- | Get type var bind name
|
||||
@ -52,26 +55,37 @@ finiteEnum tName = do
|
||||
|]
|
||||
|
||||
deriveUniverse, deriveFinite :: Name -> DecsQ
|
||||
deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
|
||||
deriveFinite tName = fmap concat . sequence $
|
||||
[ deriveUniverse' [e|concat|] [e|universeF|] tName
|
||||
, do
|
||||
DatatypeInfo{..} <- reifyDatatype tName
|
||||
[d|instance Finite $(foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars)|]
|
||||
]
|
||||
deriveUniverse tName = view _1 <$> deriveUniverse' [e|interleave|] [e|universe|] ([t|Universe|] `appT`) tName
|
||||
deriveFinite tName = do
|
||||
(decs, iCxt) <- deriveUniverse' [e|concat|] [e|universeF|] ([t|Finite|] `appT`) tName
|
||||
fmap concat . sequence $
|
||||
[ pure decs
|
||||
, do
|
||||
DatatypeInfo{..} <- reifyDatatype tName
|
||||
pure <$> instanceD (pure iCxt) (appT [t|Finite|] . foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars) []
|
||||
]
|
||||
|
||||
deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
|
||||
deriveUniverse' interleaveExp universeExp tName = do
|
||||
deriveUniverse' :: ExpQ -> ExpQ -> (TypeQ -> TypeQ) -> Name -> Q ([Dec], Cxt)
|
||||
deriveUniverse' interleaveExp universeExp mkCxt tName = do
|
||||
DatatypeInfo{..} <- reifyDatatype tName
|
||||
|
||||
let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars
|
||||
consUniverse ConstructorInfo{..} = do
|
||||
let consUniverse ConstructorInfo{..} = do
|
||||
unless (null constructorVars) $
|
||||
fail "Constructors with variables no supported"
|
||||
|
||||
foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
|
||||
|
||||
pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
|
||||
typ = foldl (\t bndr -> t `appT` varT (getTVBName bndr)) (conT tName) datatypeVars
|
||||
iCxt = map (mkCxt . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
|
||||
where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map getTVBName datatypeVars
|
||||
usesVar ConstructorInfo{..} n
|
||||
| n `elem` map getTVBName constructorVars = False
|
||||
| otherwise = any (elemOf types n) constructorFields
|
||||
fieldTypes = nub $ concatMap constructorFields datatypeCons
|
||||
|
||||
iCxt' <- cxt iCxt
|
||||
|
||||
(, iCxt') . pure <$> instanceD (pure iCxt') [t|Universe $(typ)|]
|
||||
[ funD 'universe
|
||||
[ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
|
||||
]
|
||||
|
||||
@ -47,10 +47,6 @@ import Data.Text.Lens (packed)
|
||||
import Data.List ((!!))
|
||||
|
||||
|
||||
appLanguages :: NonEmpty Lang
|
||||
appLanguages = "de-de-formal" :| ["en-eu"]
|
||||
|
||||
|
||||
pluralDE :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
-> Text -- ^ Singular
|
||||
@ -225,6 +221,11 @@ embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
|
||||
embedRenderMessage ''UniWorX ''FavouriteReason id
|
||||
embedRenderMessage ''UniWorX ''Sex id
|
||||
embedRenderMessage ''UniWorX ''ExamGradingMode id
|
||||
embedRenderMessage ''UniWorX ''ExamAidsPreset id
|
||||
embedRenderMessage ''UniWorX ''ExamOnlinePreset id
|
||||
embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
|
||||
embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
|
||||
embedRenderMessage ''UniWorX ''ChangelogItemKind id
|
||||
|
||||
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
||||
|
||||
|
||||
@ -446,7 +446,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
|
||||
guard $ userSystemMessageShown <= Just systemMessageLastChanged
|
||||
guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
|
||||
|
||||
(_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
|
||||
(_, smTrans) <- MaybeT $ getSystemMessage smId
|
||||
let
|
||||
(summary, content) = case smTrans of
|
||||
Nothing -> (systemMessageSummary, systemMessageContent)
|
||||
|
||||
@ -7,7 +7,6 @@ import Import.NoFoundation hiding (yesodMiddleware)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Routes
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
|
||||
import Utils.Metrics
|
||||
|
||||
@ -25,7 +25,7 @@ postEEditR tid ssh csh examn = do
|
||||
|
||||
return (cid, exam, template)
|
||||
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
|
||||
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template
|
||||
|
||||
formResult editExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examGradingMode = efGradingMode
|
||||
, examDescription = efDescription
|
||||
, examExamMode = efExamMode
|
||||
}
|
||||
|
||||
when (is _Nothing insertRes) $ do
|
||||
|
||||
@ -12,12 +12,14 @@ import Handler.Exam.CorrectorInvite ()
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Exam (evalExamModeDNF)
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
@ -40,6 +42,7 @@ data ExamForm = ExamForm
|
||||
, efGradingRule :: Maybe ExamGradingRule
|
||||
, efBonusRule :: Maybe ExamBonusRule
|
||||
, efOccurrenceRule :: ExamOccurrenceRule
|
||||
, efExamMode :: ExamMode
|
||||
, efCorrectors :: Set (Either UserEmail UserId)
|
||||
, efExamParts :: Set ExamPartForm
|
||||
}
|
||||
@ -117,6 +120,8 @@ examForm template html = do
|
||||
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
|
||||
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
|
||||
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
|
||||
<* aformSection MsgExamFormMode
|
||||
<*> examModeForm (efExamMode <$> template)
|
||||
<* aformSection MsgExamFormCorrection
|
||||
<*> examCorrectorsForm (efCorrectors <$> template)
|
||||
<* aformSection MsgExamFormParts
|
||||
@ -302,6 +307,7 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
Entity _ ExamCorrector{..} <- correctors
|
||||
return examCorrectorUser
|
||||
]
|
||||
, efExamMode = examExamMode
|
||||
}
|
||||
|
||||
examTemplate :: CourseId -> DB (Maybe ExamForm)
|
||||
@ -347,11 +353,12 @@ examTemplate cid = runMaybeT $ do
|
||||
, efOccurrences = Set.empty
|
||||
, efExamParts = Set.empty
|
||||
, efCorrectors = Set.empty
|
||||
, efExamMode = examExamMode oldExam
|
||||
}
|
||||
|
||||
|
||||
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
|
||||
validateExam = do
|
||||
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m ()
|
||||
validateExam cId oldExam = do
|
||||
ExamForm{..} <- State.get
|
||||
|
||||
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
|
||||
@ -377,3 +384,50 @@ validateExam = do
|
||||
]
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
|
||||
|
||||
mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
||||
E.where_ $ course E.^. CourseId E.==. E.val cId
|
||||
return school
|
||||
|
||||
whenIsJust mSchool $ \(Entity _ School{..}) -> do
|
||||
whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
|
||||
let doValidation
|
||||
| Just Exam{..} <- oldExam
|
||||
, not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
|
||||
= warnValidation
|
||||
| otherwise
|
||||
= guardValidation
|
||||
doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay)
|
||||
. fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
|
||||
whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
|
||||
let doValidation
|
||||
| Just Exam{..} <- oldExam
|
||||
, not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
|
||||
= warnValidation
|
||||
| otherwise
|
||||
= guardValidation
|
||||
doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay)
|
||||
. fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
|
||||
when schoolExamRequireModeForRegistration $ do
|
||||
let doValidation
|
||||
| Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam
|
||||
, or [ is _Nothing examAids
|
||||
, is _Nothing examOnline
|
||||
, is _Nothing examSynchronicity
|
||||
, is _Nothing examRequiredEquipment
|
||||
]
|
||||
, is _Just examRegisterFrom
|
||||
= warnValidation
|
||||
| otherwise
|
||||
= guardValidation
|
||||
let ExamMode{..} = efExamMode
|
||||
doValidation MsgExamModeRequiredForRegistration
|
||||
$ is _Nothing efRegisterFrom
|
||||
|| and [ is _Just examAids
|
||||
, is _Just examOnline
|
||||
, is _Just examSynchronicity
|
||||
, is _Just examRequiredEquipment
|
||||
]
|
||||
|
||||
warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode
|
||||
|
||||
@ -24,7 +24,7 @@ postCExamNewR tid ssh csh = do
|
||||
template <- examTemplate cid
|
||||
return (cid, template)
|
||||
|
||||
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
|
||||
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
|
||||
|
||||
formResult newExamResult $ \ExamForm{..} -> do
|
||||
insertRes <- runDBJobs $ do
|
||||
@ -49,6 +49,7 @@ postCExamNewR tid ssh csh = do
|
||||
, examGradingMode = efGradingMode
|
||||
, examPublicStatistics = efPublicStatistics
|
||||
, examDescription = efDescription
|
||||
, examExamMode = efExamMode
|
||||
}
|
||||
whenIsJust insertRes $ \examid -> do
|
||||
insertMany_
|
||||
|
||||
@ -26,8 +26,9 @@ getEShowR tid ssh csh examn = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
mUid <- maybeAuthId
|
||||
|
||||
(Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
|
||||
(Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
|
||||
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
||||
school <- getJust examCourse >>= belongsToJust courseSchool
|
||||
|
||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||
|
||||
@ -82,7 +83,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
|
||||
return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
|
||||
|
||||
let occurrenceNamesShown = lecturerInfoShown
|
||||
partNumbersShown = lecturerInfoShown
|
||||
@ -174,6 +175,11 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original examName
|
||||
|
||||
notificationDiscouragedExamMode <- runMaybeT $ do
|
||||
guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode
|
||||
guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
@ -190,4 +196,6 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
|
||||
occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
|
||||
|
||||
notificationPersonalIdentification = notification NotificationBroad =<< messageIconI Info IconPersonalIdentification MsgExamShowIdentificationRequired
|
||||
$(widgetFile "exam-show")
|
||||
|
||||
@ -5,7 +5,9 @@ import Handler.Utils
|
||||
import Handler.Info.TH
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ((!))
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
@ -34,17 +36,26 @@ getLegalR =
|
||||
|
||||
-- | Allgemeine Informationen
|
||||
getInfoR :: Handler Html
|
||||
getInfoR = -- do
|
||||
getInfoR = do
|
||||
changelogEntries' <- runDB $ selectList [] []
|
||||
let changelogEntries = Map.fromListWith Set.union
|
||||
[ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)
|
||||
| Entity _ ChangelogItemFirstSeen{..} <- changelogEntries'
|
||||
]
|
||||
|
||||
siteLayoutMsg MsgInfoHeading $ do
|
||||
setTitleI MsgInfoHeading
|
||||
let features = $(i18nWidgetFile "featureList")
|
||||
changeLog = $(i18nWidgetFile "changelog")
|
||||
changeLog = $(widgetFile "changelog")
|
||||
knownBugs = $(i18nWidgetFile "knownBugs")
|
||||
implementation = $(i18nWidgetFile "implementation")
|
||||
gitInfo :: Text
|
||||
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
|
||||
$(widgetFile "versionHistory")
|
||||
|
||||
where
|
||||
changelogItems = $(i18nWidgetFiles "changelog")
|
||||
|
||||
|
||||
getInfoLecturerR :: Handler Html
|
||||
getInfoLecturerR =
|
||||
@ -67,9 +78,9 @@ getInfoLecturerR =
|
||||
|
||||
-- new feature with given introduction date
|
||||
newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
|
||||
newFeat year month day = do
|
||||
newFeat y m d = do
|
||||
currentTime <- liftIO getCurrentTime
|
||||
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
|
||||
let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0
|
||||
if currentTime > expiryTime
|
||||
then mempty
|
||||
else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]
|
||||
@ -90,7 +101,7 @@ getGlossaryR =
|
||||
msgMap = $(glossaryTerms "glossary")
|
||||
|
||||
|
||||
mkFaqItems "faq"
|
||||
mkI18nWidgetEnum "FAQ" "faq"
|
||||
mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
|
||||
|
||||
faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
module Handler.Info.TH
|
||||
( glossaryTerms
|
||||
, mkFaqItems
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -22,52 +21,3 @@ glossaryTerms basename = do
|
||||
where
|
||||
unPathPiece :: Text -> String
|
||||
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
|
||||
|
||||
mkFaqItems :: FilePath -> DecsQ
|
||||
mkFaqItems basename = do
|
||||
itemsAvailable <- i18nWidgetFilesAvailable' basename
|
||||
let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable
|
||||
sequence
|
||||
[ dataD (cxt []) dataName [] Nothing
|
||||
[ normalC (mkName conName) []
|
||||
| (_, conName) <- Map.toAscList items
|
||||
]
|
||||
[ derivClause (Just StockStrategy)
|
||||
[ conT ''Eq
|
||||
, conT ''Ord
|
||||
, conT ''Read
|
||||
, conT ''Show
|
||||
, conT ''Enum
|
||||
, conT ''Bounded
|
||||
, conT ''Generic
|
||||
, conT ''Typeable
|
||||
]
|
||||
, derivClause (Just AnyclassStrategy)
|
||||
[ conT ''Universe
|
||||
, conT ''Finite
|
||||
]
|
||||
]
|
||||
, instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
|
||||
[ funD 'toPathPiece
|
||||
[ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
|
||||
| (int, con) <- Map.toList items
|
||||
]
|
||||
, funD 'fromPathPiece
|
||||
[ clause [varP $ mkName "t"]
|
||||
( guardedB
|
||||
[ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
|
||||
| (int, con) <- Map.toList items
|
||||
]) []
|
||||
, clause [wildP] (normalB [e|Nothing|]) []
|
||||
]
|
||||
]
|
||||
, sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|]
|
||||
, funD (mkName "faqItemMap")
|
||||
[ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
|
||||
]
|
||||
]
|
||||
where
|
||||
unPathPiece :: Text -> String
|
||||
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
|
||||
|
||||
dataName = mkName "FAQItem"
|
||||
|
||||
@ -69,7 +69,7 @@ newsSystemMessages = do
|
||||
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
|
||||
transPipe lift (selectKeys [] [])
|
||||
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
|
||||
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
|
||||
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
|
||||
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
|
||||
.| C.mapMaybeM checkHidden
|
||||
.| C.iterM (\(smId, _, _, _) -> tellShown smId)
|
||||
|
||||
@ -62,6 +62,10 @@ data SchoolForm = SchoolForm
|
||||
{ sfShorthand :: CI Text
|
||||
, sfName :: CI Text
|
||||
, sfOrgUnits :: Set (CI Text)
|
||||
, sfExamMinimumRegisterBeforeStart
|
||||
, sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
|
||||
, sfExamRequireModeForRegistration :: Bool
|
||||
, sfExamDiscouragedModes :: ExamModeDNF
|
||||
}
|
||||
|
||||
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
|
||||
@ -69,6 +73,10 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
||||
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
|
||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
|
||||
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
|
||||
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
|
||||
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
|
||||
<*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
|
||||
where
|
||||
ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
|
||||
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
|
||||
@ -82,6 +90,10 @@ schoolToForm ssh = do
|
||||
{ sfShorthand = schoolShorthand
|
||||
, sfName = schoolName
|
||||
, sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
|
||||
, sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart
|
||||
, sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
|
||||
, sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
|
||||
, sfExamDiscouragedModes = schoolExamDiscouragedModes
|
||||
}
|
||||
|
||||
|
||||
@ -94,7 +106,13 @@ postSchoolEditR ssh = do
|
||||
|
||||
formResult sfResult $ \SchoolForm{..} -> do
|
||||
runDB $ do
|
||||
update ssh [ SchoolName =. sfName ]
|
||||
update ssh
|
||||
[ SchoolName =. sfName
|
||||
, SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
|
||||
, SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
|
||||
, SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
|
||||
, SchoolExamDiscouragedModes =. sfExamDiscouragedModes
|
||||
]
|
||||
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
|
||||
void $ upsert SchoolLdap
|
||||
{ schoolLdapSchool = Just ssh
|
||||
@ -131,6 +149,10 @@ postSchoolNewR = do
|
||||
didInsert <- is _Just <$> insertUnique School
|
||||
{ schoolShorthand = sfShorthand
|
||||
, schoolName = sfName
|
||||
, schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart
|
||||
, schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
|
||||
, schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
|
||||
, schoolExamDiscouragedModes = sfExamDiscouragedModes
|
||||
}
|
||||
when didInsert $ do
|
||||
insert_ UserFunction
|
||||
|
||||
@ -25,7 +25,7 @@ getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
|
||||
getMessageR = postMessageR
|
||||
postMessageR cID = do
|
||||
smId <- decrypt cID
|
||||
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
|
||||
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId
|
||||
let (summary, content) = case translation of
|
||||
Nothing -> (systemMessageSummary, systemMessageContent)
|
||||
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
||||
@ -185,7 +185,7 @@ postMessageListR = do
|
||||
in cell . toWidget $ fromMaybe content summary
|
||||
]
|
||||
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
|
||||
smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
|
||||
smT <- (>>= view _2) <$> getSystemMessage smId
|
||||
return DBRow
|
||||
{ dbrOutput = (smE, smT)
|
||||
, ..
|
||||
|
||||
@ -213,9 +213,9 @@ formatDiffDays t
|
||||
|
||||
|
||||
setYear :: Integer -> Day -> Day
|
||||
setYear year date = fromGregorian year month day
|
||||
setYear year date = fromGregorian year m d
|
||||
where
|
||||
(_,month,day) = toGregorian date
|
||||
(_,m,d) = toGregorian date
|
||||
|
||||
addOneWeek :: UTCTime -> UTCTime
|
||||
addOneWeek = addWeeks 1
|
||||
@ -295,7 +295,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
|
||||
|
||||
|
||||
formatGregorianW :: Integer -> Int -> Int -> Widget
|
||||
formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day
|
||||
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
|
||||
|
||||
instance Csv.ToField ZonedTime where
|
||||
toField = Csv.toField . iso8601Show
|
||||
|
||||
@ -11,6 +11,8 @@ module Handler.Utils.Exam
|
||||
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
|
||||
, examAutoOccurrence
|
||||
, deregisterExamUsersCount, deregisterExamUsers
|
||||
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
|
||||
, evalExamModeDNF
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -50,6 +52,8 @@ import qualified Data.Char as Char
|
||||
|
||||
import qualified Data.RFC5051 as RFC5051
|
||||
|
||||
import Handler.Utils.I18n
|
||||
|
||||
|
||||
fetchExamAux :: ( SqlBackendCanRead backend
|
||||
, E.SqlSelect b a
|
||||
@ -641,3 +645,38 @@ deregisterExamUsersCount eId uids = do
|
||||
|
||||
deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
|
||||
deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids
|
||||
|
||||
|
||||
examAidsPresetWidget :: ExamAidsPreset -> Widget
|
||||
examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids")
|
||||
|
||||
examOnlinePresetWidget :: ExamOnlinePreset -> Widget
|
||||
examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online")
|
||||
|
||||
examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget
|
||||
examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity")
|
||||
|
||||
examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget
|
||||
examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment")
|
||||
|
||||
|
||||
evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool
|
||||
evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
|
||||
= dnfTerms
|
||||
& map (Set.toList . toNullable) . Set.toList
|
||||
& map ( maybe True (ofoldr1 (&&))
|
||||
. fromNullable
|
||||
. map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl)
|
||||
)
|
||||
& maybe False (ofoldr1 (||)) . fromNullable
|
||||
where
|
||||
evalPred :: ExamModePredicate -> Bool
|
||||
evalPred = \case
|
||||
ExamModePredAids p
|
||||
-> examAids == Just (ExamAidsPreset p)
|
||||
ExamModePredOnline p
|
||||
-> examOnline == Just (ExamOnlinePreset p)
|
||||
ExamModePredSynchronicity p
|
||||
-> examSynchronicity == Just (ExamSynchronicityPreset p)
|
||||
ExamModePredRequiredEquipment p
|
||||
-> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)
|
||||
|
||||
@ -19,6 +19,8 @@ import Handler.Utils.I18n
|
||||
|
||||
import Handler.Utils.Files
|
||||
|
||||
import Handler.Utils.Exam
|
||||
|
||||
import Import
|
||||
import Data.Char ( chr, ord, isDigit )
|
||||
import qualified Data.Char as Char
|
||||
@ -1936,3 +1938,97 @@ courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (
|
||||
userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
-> Handler (OptionList UserId)
|
||||
userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName
|
||||
|
||||
|
||||
data CustomPresetFormOption p
|
||||
= CPFONone
|
||||
| CPFOPreset p
|
||||
| CPFOCustom
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveFinite ''CustomPresetFormOption
|
||||
derivePathPiece ''CustomPresetFormOption (camelToPathPiece' 1) "--"
|
||||
|
||||
customPresetForm :: forall a custom preset msg.
|
||||
( Finite preset, Ord preset, PathPiece preset
|
||||
, RenderMessage UniWorX msg
|
||||
)
|
||||
=> Iso' a (Either custom preset)
|
||||
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
|
||||
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for custom option
|
||||
-> (preset -> (msg, Maybe Widget))
|
||||
-> (Maybe custom -> AForm Handler custom)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe (Maybe a)
|
||||
-> AForm Handler (Maybe a)
|
||||
customPresetForm cpL noneOption customOption toOption customForm fs mPrev
|
||||
= explainedMultiActionA actionMap options fs mPrev'
|
||||
where
|
||||
mPrev' = flip fmap mPrev $ preview (_Just . cpL) >>> \case
|
||||
Nothing -> CPFONone
|
||||
Just (Left _) -> CPFOCustom
|
||||
Just (Right p) -> CPFOPreset p
|
||||
|
||||
options = explainOptionList options' $ hoistMaybe . optionToWidget
|
||||
where options' = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let olReadExternal t = do
|
||||
opt <- fromPathPiece t
|
||||
case opt of
|
||||
CPFONone -> opt <$ hoistMaybe noneOption
|
||||
CPFOCustom -> opt <$ hoistMaybe customOption
|
||||
CPFOPreset _ -> pure opt
|
||||
olOptions = do
|
||||
optionInternalValue <- universeF
|
||||
optionDisplay <- case optionInternalValue of
|
||||
CPFONone -> views _1 mr <$> hoistMaybe noneOption
|
||||
CPFOCustom -> views _1 mr <$> hoistMaybe customOption
|
||||
CPFOPreset p -> return . views _1 mr $ toOption p
|
||||
let optionExternalValue = toPathPiece optionInternalValue
|
||||
return Option{..}
|
||||
return OptionList{..}
|
||||
optionToWidget = \case
|
||||
CPFONone -> noneOption ^? _Just . _2 . _Just
|
||||
CPFOCustom -> customOption ^? _Just . _2 . _Just
|
||||
CPFOPreset p -> toOption p ^. _2
|
||||
|
||||
actionMap :: Map (CustomPresetFormOption preset) (AForm Handler (Maybe a))
|
||||
actionMap = Map.fromList $ do
|
||||
opt <- universeF
|
||||
return . (opt, ) $ case opt of
|
||||
CPFONone -> pure Nothing
|
||||
CPFOPreset p -> pure . Just $ cpL # Right p
|
||||
CPFOCustom -> reviews cpL Just . Left <$> customForm (mPrev ^? _Just . _Just . cpL . _Left)
|
||||
|
||||
examModeForm :: Maybe ExamMode -> AForm Handler ExamMode
|
||||
examModeForm mPrev = examMode
|
||||
<$> customPresetForm examSynchronicityEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examSynchronicityPresetWidget) (apreq htmlField (fslI MsgExamModeFormSynchronicity)) (fslI MsgExamModeFormSynchronicity) (examSynchronicity <$> mPrev)
|
||||
<*> customPresetForm examOnlineEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examOnlinePresetWidget) (apreq htmlField (fslI MsgExamModeFormOnline)) (fslI MsgExamModeFormOnline) (examOnline <$> mPrev)
|
||||
<*> customPresetForm examAidsEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examAidsPresetWidget) (apreq htmlField (fslI MsgExamModeFormAids)) (fslI MsgExamModeFormAids) (examAids <$> mPrev)
|
||||
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
|
||||
where
|
||||
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
|
||||
|
||||
examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset)
|
||||
examAidsEither = iso examAidsToEither examAidsFromEither
|
||||
where examAidsToEither (ExamAidsPreset p) = Right p
|
||||
examAidsToEither (ExamAidsCustom c) = Left c
|
||||
examAidsFromEither (Right p) = ExamAidsPreset p
|
||||
examAidsFromEither (Left c) = ExamAidsCustom c
|
||||
examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset)
|
||||
examOnlineEither = iso examOnlineToEither examOnlineFromEither
|
||||
where examOnlineToEither (ExamOnlinePreset p) = Right p
|
||||
examOnlineToEither (ExamOnlineCustom c) = Left c
|
||||
examOnlineFromEither (Right p) = ExamOnlinePreset p
|
||||
examOnlineFromEither (Left c) = ExamOnlineCustom c
|
||||
examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset)
|
||||
examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
|
||||
where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
|
||||
examSynchronicityToEither (ExamSynchronicityCustom c) = Left c
|
||||
examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
|
||||
examSynchronicityFromEither (Left c) = ExamSynchronicityCustom c
|
||||
examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset)
|
||||
examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
|
||||
where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
|
||||
examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c
|
||||
examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
|
||||
examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c
|
||||
|
||||
@ -1,24 +1,22 @@
|
||||
module Handler.Utils.I18n
|
||||
( i18nWidgetFile
|
||||
, i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
|
||||
, i18nWidgetFiles
|
||||
, module Utils.I18n
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Foundation.I18n
|
||||
|
||||
import Utils.I18n
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (qRunIO)
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import System.Directory (listDirectory)
|
||||
|
||||
|
||||
@ -51,20 +49,6 @@ i18nWidgetFile basename = do
|
||||
] ++ [ 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)|]
|
||||
|
||||
i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
|
||||
i18nWidgetFilesAvailable' basename = do
|
||||
let i18nDirectory = "templates" </> "i18n" </> basename
|
||||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||||
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
||||
fileKinds :: Map Text [Text]
|
||||
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
||||
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
|
||||
|
||||
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
||||
|
||||
i18nWidgetFilesAvailable :: FilePath -> Q Exp
|
||||
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
|
||||
|
||||
i18nWidgetFiles :: FilePath -> Q Exp
|
||||
i18nWidgetFiles basename = do
|
||||
availableTranslations' <- i18nWidgetFilesAvailable' basename
|
||||
|
||||
@ -45,6 +45,10 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag
|
||||
|
||||
import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
|
||||
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
|
||||
import qualified Data.Time.Zones as TZ
|
||||
|
||||
-- Database versions must follow https://pvp.haskell.org:
|
||||
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
|
||||
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
|
||||
@ -168,6 +172,19 @@ migrateManual = do
|
||||
, ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )
|
||||
, ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" )
|
||||
]
|
||||
|
||||
recordedChangelogItems <- lift . lift $ selectList [] []
|
||||
let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems'
|
||||
where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ]
|
||||
unless (null missingChangelogItems) $ do
|
||||
now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
addMigration False $
|
||||
let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|]
|
||||
vals = Text.intercalate ", " $ do
|
||||
item <- missingChangelogItems
|
||||
return [st|('#{toPathPiece item}', '#{now}')|]
|
||||
in sql
|
||||
|
||||
where
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
addIndex ixName ixDef = do
|
||||
@ -950,6 +967,26 @@ customMigrations = Map.fromListWith (>>)
|
||||
INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|41.0.0|] [version|42.0.0|]
|
||||
, do
|
||||
whenM (tableExists "exam")
|
||||
[executeQQ|
|
||||
ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing};
|
||||
|]
|
||||
whenM (tableExists "school")
|
||||
[executeQQ|
|
||||
ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse};
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
|
||||
, unlessM (tableExists "changelog_item_first_seen") $ do
|
||||
[executeQQ|
|
||||
CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL);
|
||||
|]
|
||||
insertMany_ [ ChangelogItemFirstSeen{..}
|
||||
| (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -17,3 +17,4 @@ import Model.Types.Allocation as Types
|
||||
import Model.Types.Languages as Types
|
||||
import Model.Types.File as Types
|
||||
import Model.Types.User as Types
|
||||
import Model.Types.Changelog as Types
|
||||
|
||||
145
src/Model/Types/Changelog.hs
Normal file
145
src/Model/Types/Changelog.hs
Normal file
@ -0,0 +1,145 @@
|
||||
module Model.Types.Changelog
|
||||
( ChangelogItem(..)
|
||||
, changelogItemMap
|
||||
, ChangelogItemKind(..), _ChangelogItemFeature, _ChangelogItemBugfix
|
||||
, classifyChangelogItem
|
||||
, changelogItemDays
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
mkI18nWidgetEnum "Changelog" "changelog"
|
||||
derivePersistFieldPathPiece ''ChangelogItem
|
||||
pathPieceJSONKey ''ChangelogItem
|
||||
pathPieceJSON ''ChangelogItem
|
||||
pathPieceHttpApiData ''ChangelogItem
|
||||
|
||||
data ChangelogItemKind
|
||||
= ChangelogItemFeature
|
||||
| ChangelogItemBugfix
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
makePrisms ''ChangelogItemKind
|
||||
|
||||
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
|
||||
classifyChangelogItem = \case
|
||||
ChangelogHaskellCampusLogin -> ChangelogItemBugfix
|
||||
ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
|
||||
ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
|
||||
ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
|
||||
ChangelogPassingByPointsWorks -> ChangelogItemBugfix
|
||||
ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
|
||||
ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
|
||||
ChangelogFormsTimesReset -> ChangelogItemBugfix
|
||||
_other -> ChangelogItemFeature
|
||||
|
||||
changelogItemDays :: Map ChangelogItem Day
|
||||
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
|
||||
[ (ChangelogConfigurableDatetimeFormat, [day|2018-07-10|])
|
||||
, (ChangelogCourseListOverAllTerms, [day|2018-07-31|])
|
||||
, (ChangelogCorrectionsDisplayImprovements, [day|2018-07-31|])
|
||||
, (ChangelogHaskellCampusLogin, [day|2018-08-01|])
|
||||
, (ChangelogFileDownloadOption, [day|2018-08-06|])
|
||||
, (ChangelogSheetsNoSubmissionAndZipControl, [day|2018-09-18|])
|
||||
, (ChangelogSmartCorrectionDistribution, [day|2018-09-18|])
|
||||
, (ChangelogTableSummaries, [day|2018-09-18|])
|
||||
, (ChangelogPersonalInformation, [day|2018-09-18|])
|
||||
, (ChangelogCourseShorthandsWithinSchools, [day|2018-09-18|])
|
||||
, (ChangelogTooltipsWithoutJavascript, [day|2018-09-18|])
|
||||
, (ChangelogEmailNotifications, [day|2018-10-19|])
|
||||
, (ChangelogSupportWidget, [day|2018-10-19|])
|
||||
, (ChangelogAccountDeletionDuringTesting, [day|2018-10-19|])
|
||||
, (ChangelogImprovementsForCorrectors, [day|2018-11-09|])
|
||||
, (ChangelogButtonsWorkWithoutJavascript, [day|2018-11-09|])
|
||||
, (ChangelogTableFormsWorkAfterAjax, [day|2018-11-29|])
|
||||
, (ChangelogPassingByPointsWorks, [day|2018-11-30|])
|
||||
, (ChangelogErrorMessagesForTableItemVanish, [day|2019-01-16|])
|
||||
, (ChangelogAssignedCorrectionsFilters, [day|2019-01-16|])
|
||||
, (ChangelogCourseConvenienceLinks, [day|2019-01-16|])
|
||||
, (ChangelogAsidenav, [day|2019-01-30|])
|
||||
, (ChangelogCourseAssociatedStudyField, [day|2019-03-20|])
|
||||
, (ChangelogStudyFeatures, [day|2019-03-27|])
|
||||
, (ChangelogCourseAdministratorRoles, [day|2019-03-27|])
|
||||
, (ChangelogCourseAdministratorInvitations, [day|2019-04-20|])
|
||||
, (ChangelogCourseMessages, [day|2019-04-20|])
|
||||
, (ChangelogCorrectorsOnCourseShow, [day|2019-04-29|])
|
||||
, (ChangelogTutorials, [day|2019-04-29|])
|
||||
, (ChangelogCourseMaterials, [day|2019-05-04|])
|
||||
, (ChangelogDownloadAllSheetFiles, [day|2019-05-10|])
|
||||
, (ChangelogImprovedSubmittorUi, [day|2019-05-10|])
|
||||
, (ChangelogCourseRegisterByAdmin, [day|2019-05-13|])
|
||||
, (ChangelogReworkedAutomaticCorrectionDistribution, [day|2019-05-20|])
|
||||
, (ChangelogDownloadAllSheetFilesByType, [day|2019-06-07|])
|
||||
, (ChangelogSheetSpecificFiles, [day|2019-06-07|])
|
||||
, (ChangelogExams, [day|2019-06-26|])
|
||||
, (ChangelogCsvExamParticipants, [day|2019-07-23|])
|
||||
, (ChangelogAllocationCourseRegistration, [day|2019-08-12|])
|
||||
, (ChangelogAllocationApplications, [day|2019-08-19|])
|
||||
, (ChangelogCsvCourseApplications, [day|2019-08-27|])
|
||||
, (ChangelogAllocationsNotifications, [day|2019-09-05|])
|
||||
, (ChangelogConfigurableDisplayEmails, [day|2019-09-12|])
|
||||
, (ChangelogConfigurableDisplayNames, [day|2019-09-12|])
|
||||
, (ChangelogEstimateAllocatedCourseCapacity, [day|2019-09-12|])
|
||||
, (ChangelogNotificationExamRegistration, [day|2019-09-13|])
|
||||
, (ChangelogExamClosure, [day|2019-09-16|])
|
||||
, (ChangelogExamOfficeExamNotification, [day|2019-09-16|])
|
||||
, (ChangelogExamOffices, [day|2019-09-16|])
|
||||
, (ChangelogExamAchievementParticipantDuplication, [day|2019-09-25|])
|
||||
, (ChangelogFormsTimesReset, [day|2019-09-25|])
|
||||
, (ChangelogExamAutomaticResults, [day|2019-09-25|])
|
||||
, (ChangelogExamAutomaticBoni, [day|2019-09-25|])
|
||||
, (ChangelogAutomaticallyAcceptCourseApplications, [day|2019-09-27|])
|
||||
, (ChangelogCourseNews, [day|2019-10-01|])
|
||||
, (ChangelogCsvExportCourseParticipants, [day|2019-10-08|])
|
||||
, (ChangelogNotificationCourseParticipantViaAdmin, [day|2019-10-08|])
|
||||
, (ChangelogCsvExportCourseParticipantsFeatures, [day|2019-10-09|])
|
||||
, (ChangelogCourseOccurences, [day|2019-10-09|])
|
||||
, (ChangelogTutorialRegistrationViaParticipantTable, [day|2019-10-10|])
|
||||
, (ChangelogCsvExportCourseParticipantsRegisteredTutorials, [day|2019-10-10|])
|
||||
, (ChangelogCourseParticipantsSex, [day|2019-10-14|])
|
||||
, (ChangelogTutorialTutorControl, [day|2019-10-14|])
|
||||
, (ChangelogCsvOptionCharacterSet, [day|2019-10-23|])
|
||||
, (ChangelogCsvOptionTimestamp, [day|2019-10-23|])
|
||||
, (ChangelogEnglish, [day|2019-10-31|])
|
||||
, (ChangelogI18n, [day|2019-10-31|])
|
||||
, (ChangelogLmuInternalFields, [day|2019-11-28|])
|
||||
, (ChangelogNotificationSubmissionChanged, [day|2019-12-05|])
|
||||
, (ChangelogExportCourseParticipants, [day|2020-01-17|])
|
||||
, (ChangelogExternalExams, [day|2020-01-17|])
|
||||
, (ChangelogExamAutomaticRoomDistribution, [day|2020-01-29|])
|
||||
, (ChangelogWarningMultipleSemesters, [day|2020-01-30|])
|
||||
, (ChangelogExamAutomaticRoomDistributionBetterRulesDisplay, [day|2020-01-30|])
|
||||
, (ChangelogReworkedNavigation, [day|2020-02-07|])
|
||||
, (ChangelogExamCorrect, [day|2020-02-08|])
|
||||
, (ChangelogExamGradingMode, [day|2020-02-19|])
|
||||
, (ChangelogMarkdownEmails, [day|2020-02-23|])
|
||||
, (ChangelogMarkdownHtmlInput, [day|2020-02-23|])
|
||||
, (ChangelogBetterCsvImport, [day|2020-03-06|])
|
||||
, (ChangelogAdditionalDatetimeFormats, [day|2020-03-16|])
|
||||
, (ChangelogServerSideSessions, [day|2020-03-16|])
|
||||
, (ChangelogWebinterfaceAllocationAllocation, [day|2020-03-16|])
|
||||
, (ChangelogBetterTableCellColourCoding, [day|2020-03-16|])
|
||||
, (ChangelogCourseOccurrenceNotes, [day|2020-03-31|])
|
||||
, (ChangelogHideSystemMessages, [day|2020-04-15|])
|
||||
, (ChangelogNonAnonymisedCorrection, [day|2020-04-17|])
|
||||
, (ChangelogBetterCourseParticipantDetailPage, [day|2020-04-17|])
|
||||
, (ChangelogFaq, [day|2020-04-24|])
|
||||
, (ChangelogRegisteredSubmissionGroups, [day|2020-04-28|])
|
||||
, (ChangelogFormerCourseParticipants, [day|2020-05-05|])
|
||||
, (ChangelogBetterFileUploads, [day|2020-05-05|])
|
||||
, (ChangelogSheetPassAlways, [day|2020-05-23|])
|
||||
, (ChangelogBetterCourseCommunicationTutorials, [day|2020-05-25|])
|
||||
, (ChangelogAdditionalSheetNotifications, [day|2020-05-25|])
|
||||
, (ChangelogCourseParticipantsListAddSheets, [day|2020-06-14|])
|
||||
, (ChangelogYamlRatings, [day|2020-06-17|])
|
||||
, (ChangelogSubmissionOnlyExamRegistered, [day|2020-07-20|])
|
||||
, (ChangelogCourseVisibility, [day|2020-08-10|])
|
||||
, (ChangelogPersonalisedSheetFiles, [day|2020-08-10|])
|
||||
, (ChangelogAbolishCourseAssociatedStudyFeatures, [day|2020-08-28|])
|
||||
]
|
||||
@ -32,6 +32,12 @@ module Model.Types.Exam
|
||||
, hasExamGradingPass, hasExamGradingGrades
|
||||
, ExamPartNumber
|
||||
, _ExamPartNumber, _ExamPartNumber'
|
||||
, ExamAids(..), ExamAidsPreset(..)
|
||||
, ExamOnline(..), ExamOnlinePreset(..)
|
||||
, ExamSynchronicity(..), ExamSynchronicityPreset(..)
|
||||
, ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..)
|
||||
, ExamMode(..)
|
||||
, ExamModePredicate(..), ExamModeDNF(..)
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -59,6 +65,8 @@ import qualified Data.Foldable
|
||||
|
||||
import Data.Aeson (genericToJSON, genericParseJSON)
|
||||
|
||||
import Model.Types.Security
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
@ -427,3 +435,125 @@ pathPieceJSONKey ''ExamPartNumber
|
||||
instance Enum ExamPartNumber where
|
||||
toEnum = review _ExamPartNumber' . toEnum
|
||||
fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber'
|
||||
|
||||
|
||||
data ExamAids
|
||||
= ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
|
||||
| ExamAidsCustom { examAidsCustom :: Html }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data ExamAidsPreset
|
||||
= ExamOpenBook
|
||||
| ExamClosedBook
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
, sumEncoding = TaggedObject "mode" "data"
|
||||
} ''ExamAids
|
||||
derivePersistFieldJSON ''ExamAids
|
||||
|
||||
nullaryPathPiece' ''ExamAidsPreset $ nameToPathPiece' 1
|
||||
pathPieceJSON ''ExamAidsPreset
|
||||
|
||||
data ExamOnline
|
||||
= ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
|
||||
| ExamOnlineCustom { examOnlineCustom :: Html }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data ExamOnlinePreset
|
||||
= ExamOnline
|
||||
| ExamOffline
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
, sumEncoding = TaggedObject "mode" "data"
|
||||
} ''ExamOnline
|
||||
derivePersistFieldJSON ''ExamOnline
|
||||
|
||||
nullaryPathPiece' ''ExamOnlinePreset $ nameToPathPiece' 1
|
||||
pathPieceJSON ''ExamOnlinePreset
|
||||
|
||||
data ExamSynchronicity
|
||||
= ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
|
||||
| ExamSynchronicityCustom { examSynchronicityCustom :: Html }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data ExamSynchronicityPreset
|
||||
= ExamSynchronous
|
||||
| ExamAsynchronous
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
, sumEncoding = TaggedObject "mode" "data"
|
||||
} ''ExamSynchronicity
|
||||
derivePersistFieldJSON ''ExamSynchronicity
|
||||
|
||||
nullaryPathPiece' ''ExamSynchronicityPreset $ nameToPathPiece' 1
|
||||
pathPieceJSON ''ExamSynchronicityPreset
|
||||
|
||||
data ExamRequiredEquipment
|
||||
= ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
|
||||
| ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data ExamRequiredEquipmentPreset
|
||||
= ExamRequiredEquipmentNone
|
||||
| ExamRequiredEquipmentPen
|
||||
| ExamRequiredEquipmentPaperPen
|
||||
| ExamRequiredEquipmentCalculatorPen
|
||||
| ExamRequiredEquipmentCalculatorPaperPen
|
||||
| ExamRequiredEquipmentWebcamMicrophoneInternet
|
||||
| ExamRequiredEquipmentMicrophoneInternet
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
, sumEncoding = TaggedObject "mode" "data"
|
||||
} ''ExamRequiredEquipment
|
||||
derivePersistFieldJSON ''ExamRequiredEquipment
|
||||
|
||||
nullaryPathPiece' ''ExamRequiredEquipmentPreset $ nameToPathPiece' 3
|
||||
pathPieceJSON ''ExamRequiredEquipmentPreset
|
||||
|
||||
|
||||
data ExamMode = ExamMode
|
||||
{ examAids :: Maybe ExamAids
|
||||
, examOnline :: Maybe ExamOnline
|
||||
, examSynchronicity :: Maybe ExamSynchronicity
|
||||
, examRequiredEquipment :: Maybe ExamRequiredEquipment
|
||||
}
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''ExamMode
|
||||
derivePersistFieldJSON ''ExamMode
|
||||
|
||||
data ExamModePredicate
|
||||
= ExamModePredAids ExamAidsPreset
|
||||
| ExamModePredOnline ExamOnlinePreset
|
||||
| ExamModePredSynchronicity ExamSynchronicityPreset
|
||||
| ExamModePredRequiredEquipment ExamRequiredEquipmentPreset
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 3
|
||||
, sumEncoding = TaggedObject "setting" "preset"
|
||||
} ''ExamModePredicate
|
||||
derivePathPiece ''ExamModePredicate (camelToPathPiece' 3) "--"
|
||||
deriveFinite ''ExamModePredicate
|
||||
|
||||
newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece)
|
||||
|
||||
derivePersistFieldJSON ''ExamModeDNF
|
||||
|
||||
@ -184,6 +184,9 @@ dnfAssumeValue var val
|
||||
disagrees PLNegated{..} = plVar == var && val
|
||||
disagrees PLVariable{..} = plVar == var && not val
|
||||
|
||||
predDNFFalse :: PredDNF a
|
||||
predDNFFalse = PredDNF Set.empty
|
||||
|
||||
|
||||
data UserGroupName
|
||||
= UserGroupMetrics
|
||||
|
||||
@ -12,6 +12,7 @@ module Settings
|
||||
, module Settings.Mime
|
||||
, module Settings.Cookies
|
||||
, module Settings.Log
|
||||
, module Settings.Locale
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -55,6 +56,7 @@ import Settings.Cluster
|
||||
import Settings.Mime
|
||||
import Settings.Cookies
|
||||
import Settings.Log
|
||||
import Settings.Locale
|
||||
|
||||
import qualified System.FilePath as FilePath
|
||||
|
||||
@ -605,10 +607,3 @@ compileTimeAppSettings =
|
||||
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
|
||||
Aeson.Error e -> error e
|
||||
Aeson.Success settings -> settings
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
|
||||
|
||||
appTZ :: TZ
|
||||
appTZ = $(includeSystemTZ "Europe/Berlin")
|
||||
|
||||
21
src/Settings/Locale.hs
Normal file
21
src/Settings/Locale.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Settings.Locale
|
||||
( getTimeLocale'
|
||||
, appTZ
|
||||
, appLanguages
|
||||
) where
|
||||
|
||||
import Utils.DateTime
|
||||
|
||||
import Data.List.NonEmpty
|
||||
|
||||
import Text.Shakespeare.I18N (Lang)
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
|
||||
|
||||
appTZ :: TZ
|
||||
appTZ = $(includeSystemTZ "Europe/Berlin")
|
||||
|
||||
appLanguages :: NonEmpty Lang
|
||||
appLanguages = "de-de-formal" :| ["en-eu"]
|
||||
12
src/Utils.hs
12
src/Utils.hs
@ -31,6 +31,7 @@ import Utils.Cookies as Utils
|
||||
import Utils.Cookies.Registered as Utils
|
||||
import Utils.Session as Utils
|
||||
import Utils.Csv as Utils
|
||||
import Utils.NTop as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
@ -654,16 +655,7 @@ ignoreNothing _ Nothing y = y
|
||||
ignoreNothing _ x Nothing = x
|
||||
ignoreNothing f (Just x) (Just y) = Just $ f x y
|
||||
|
||||
newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
|
||||
|
||||
instance Eq a => Eq (NTop (Maybe a)) where
|
||||
(NTop x) == (NTop y) = x == y
|
||||
|
||||
instance Ord a => Ord (NTop (Maybe a)) where
|
||||
compare (NTop Nothing) (NTop Nothing) = EQ
|
||||
compare (NTop Nothing) _ = GT
|
||||
compare _ (NTop Nothing) = LT
|
||||
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
||||
-- `NTop` moved to `Utils.NTop`
|
||||
|
||||
exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
|
||||
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
|
||||
|
||||
@ -12,6 +12,7 @@ module Utils.DateTime
|
||||
, nominalHour, nominalMinute
|
||||
, minNominalYear, avgNominalYear
|
||||
, module Zones
|
||||
, day
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (lift)
|
||||
@ -23,12 +24,14 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ)
|
||||
import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
|
||||
import Data.Time.Format (FormatTime)
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
import qualified Data.Time.Format.ISO8601 as Time
|
||||
import qualified Data.Time.Format as Time
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (Lift(..))
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
import Data.Data (Data)
|
||||
@ -45,6 +48,8 @@ import Algebra.Lattice.Ordered
|
||||
|
||||
import Control.Monad.Fail
|
||||
|
||||
import Utils.Lang (selectLanguage')
|
||||
|
||||
|
||||
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
|
||||
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
|
||||
@ -142,3 +147,15 @@ nominalMinute = 60
|
||||
minNominalYear, avgNominalYear :: NominalDiffTime
|
||||
minNominalYear = 365 * nominalDay
|
||||
avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
|
||||
|
||||
---------
|
||||
-- Day --
|
||||
---------
|
||||
|
||||
day :: QuasiQuoter
|
||||
day = QuasiQuoter{..}
|
||||
where
|
||||
quotePat = error "day used as pattern"
|
||||
quoteType = error "day used as type"
|
||||
quoteDec = error "day used as declaration"
|
||||
quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr
|
||||
|
||||
44
src/Utils/I18n.hs
Normal file
44
src/Utils/I18n.hs
Normal file
@ -0,0 +1,44 @@
|
||||
module Utils.I18n
|
||||
( i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Settings.Locale (appLanguages)
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (qRunIO)
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
import qualified Data.List as List
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import System.FilePath
|
||||
import System.Directory (listDirectory)
|
||||
|
||||
import Utils.NTop
|
||||
|
||||
import Control.Lens (iforM)
|
||||
import Control.Monad.Fail (fail)
|
||||
|
||||
|
||||
|
||||
i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
|
||||
i18nWidgetFilesAvailable' basename = do
|
||||
let i18nDirectory = "templates" </> "i18n" </> basename
|
||||
availableFiles <- qRunIO $ listDirectory i18nDirectory
|
||||
let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
|
||||
fileKinds :: Map Text [Text]
|
||||
fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
|
||||
toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
|
||||
|
||||
iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
|
||||
|
||||
i18nWidgetFilesAvailable :: FilePath -> Q Exp
|
||||
i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
|
||||
|
||||
@ -89,6 +89,7 @@ data Icon
|
||||
| IconNotification | IconNoNotification
|
||||
| IconAllocationRegister | IconAllocationRegistrationEdit
|
||||
| IconAllocationApplicationEdit
|
||||
| IconPersonalIdentification
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
|
||||
|
||||
iconText :: Icon -> Text
|
||||
@ -158,6 +159,7 @@ iconText = \case
|
||||
IconAllocationRegister -> "user-plus"
|
||||
IconAllocationRegistrationEdit -> "pencil-alt"
|
||||
IconAllocationApplicationEdit -> "pencil-alt"
|
||||
IconPersonalIdentification -> "id-card"
|
||||
|
||||
instance Universe Icon
|
||||
instance Finite Icon
|
||||
|
||||
17
src/Utils/NTop.hs
Normal file
17
src/Utils/NTop.hs
Normal file
@ -0,0 +1,17 @@
|
||||
module Utils.NTop
|
||||
( NTop(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
-- | treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
|
||||
newtype NTop a = NTop { nBot :: a }
|
||||
deriving (Read, Show, Generic, Typeable)
|
||||
deriving newtype (Eq)
|
||||
|
||||
instance Ord a => Ord (NTop (Maybe a)) where
|
||||
compare (NTop Nothing) (NTop Nothing) = EQ
|
||||
compare (NTop Nothing) _ = GT
|
||||
compare _ (NTop Nothing) = LT
|
||||
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
||||
|
||||
@ -8,6 +8,7 @@ module Utils.PathPiece
|
||||
, tuplePathPiece
|
||||
, pathPieceJSON, pathPieceJSONKey
|
||||
, pathPieceBinary
|
||||
, pathPieceHttpApiData
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -27,7 +28,7 @@ import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import Data.List (foldl)
|
||||
import Data.List (nub, foldl)
|
||||
|
||||
import Data.Aeson.Types
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
@ -37,6 +38,11 @@ import Control.Monad.Fail
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Control.Lens
|
||||
import Data.Generics.Product.Types
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
|
||||
mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
|
||||
mkFiniteFromPathPiece finiteType = do
|
||||
@ -105,7 +111,7 @@ derivePathPiece adt mangle joinPP = do
|
||||
[]
|
||||
finDecs =
|
||||
[ pragInlD mapName NoInline FunLike AllPhases
|
||||
, sigD mapName [t|HashMap Text ([Text] -> Maybe $(conT adt))|]
|
||||
, sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
|
||||
, funD mapName
|
||||
[ clause [] (normalB finClause) [] ]
|
||||
]
|
||||
@ -123,8 +129,17 @@ derivePathPiece adt mangle joinPP = do
|
||||
, match wildP (normalB [e|Nothing|]) []
|
||||
]
|
||||
]
|
||||
typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars
|
||||
iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
|
||||
where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars
|
||||
usesVar ConstructorInfo{..} n
|
||||
| n `elem` map tvarName constructorVars = False
|
||||
| otherwise = any (elemOf types n) constructorFields
|
||||
fieldTypes = nub $ concatMap constructorFields datatypeCons
|
||||
tvarName (PlainTV n) = n
|
||||
tvarName (KindedTV n _) = n
|
||||
sequence . (finDecs ++ ) . pure $
|
||||
instanceD (cxt []) [t|PathPiece $(conT adt)|]
|
||||
instanceD (cxt iCxt) [t|PathPiece $(typ)|]
|
||||
[ funD 'toPathPiece
|
||||
(map toClause datatypeCons)
|
||||
, funD 'fromPathPiece
|
||||
@ -217,3 +232,11 @@ pathPieceBinary tName
|
||||
get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece
|
||||
put = Binary.put . toPathPiece
|
||||
|]
|
||||
|
||||
pathPieceHttpApiData :: Name -> DecsQ
|
||||
pathPieceHttpApiData tName
|
||||
= [d| instance ToHttpApiData $(conT tName) where
|
||||
toUrlPiece = toPathPiece
|
||||
instance FromHttpApiData $(conT tName) where
|
||||
parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece
|
||||
|]
|
||||
|
||||
@ -7,10 +7,9 @@ import Data.List (findIndex)
|
||||
|
||||
|
||||
getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
|
||||
=> NonEmpty Lang -- ^ `appLanguages`
|
||||
-> SystemMessageId
|
||||
=> SystemMessageId
|
||||
-> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
|
||||
getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
|
||||
getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
|
||||
SystemMessage{..} <- MaybeT $ get smId
|
||||
translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
|
||||
let
|
||||
|
||||
@ -13,8 +13,18 @@ import Language.Haskell.TH.Datatype
|
||||
|
||||
import Data.List ((!!), foldl)
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Fail
|
||||
|
||||
import Utils.I18n
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import Data.Universe (Universe, Finite)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
------------
|
||||
@ -188,3 +198,56 @@ dispatchTH dType = do
|
||||
let fName = mkName $ "dispatch" <> nameBase constructorName
|
||||
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
|
||||
lamCaseE matches
|
||||
|
||||
|
||||
mkI18nWidgetEnum :: String -> FilePath -> DecsQ
|
||||
mkI18nWidgetEnum (splitCamel -> namebase) basename = do
|
||||
itemsAvailable <- i18nWidgetFilesAvailable' basename
|
||||
let items = Map.mapWithKey (\k _ -> typPrefix <> unPathPiece k) itemsAvailable
|
||||
sequence
|
||||
[ dataD (cxt []) dataName [] Nothing
|
||||
[ normalC (mkName conName) []
|
||||
| (_, conName) <- Map.toAscList items
|
||||
]
|
||||
[ derivClause (Just StockStrategy)
|
||||
[ conT ''Eq
|
||||
, conT ''Ord
|
||||
, conT ''Read
|
||||
, conT ''Show
|
||||
, conT ''Enum
|
||||
, conT ''Bounded
|
||||
, conT ''Generic
|
||||
, conT ''Typeable
|
||||
]
|
||||
, derivClause (Just AnyclassStrategy)
|
||||
[ conT ''Universe
|
||||
, conT ''Finite
|
||||
]
|
||||
]
|
||||
, instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
|
||||
[ funD 'toPathPiece
|
||||
[ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
|
||||
| (int, con) <- Map.toList items
|
||||
]
|
||||
, funD 'fromPathPiece
|
||||
[ clause [varP $ mkName "t"]
|
||||
( guardedB
|
||||
[ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
|
||||
| (int, con) <- Map.toList items
|
||||
]) []
|
||||
, clause [wildP] (normalB [e|Nothing|]) []
|
||||
]
|
||||
]
|
||||
, sigD (mkName $ valPrefix <> "ItemMap") [t|Map Text $(conT dataName)|]
|
||||
, funD (mkName $ valPrefix <> "ItemMap")
|
||||
[ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
|
||||
]
|
||||
]
|
||||
where
|
||||
unPathPiece :: Text -> String
|
||||
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
|
||||
|
||||
dataName = mkName $ typPrefix <> "Item"
|
||||
|
||||
typPrefix = concat $ over (takingWhile Char.isLower $ _head . traverse) Char.toUpper namebase
|
||||
valPrefix = concat $ over (takingWhile Char.isUpper $ _head . traverse) Char.toLower namebase
|
||||
|
||||
14
templates/changelog.hamlet
Normal file
14
templates/changelog.hamlet
Normal file
@ -0,0 +1,14 @@
|
||||
$newline never
|
||||
<dl .deflist #changelog>
|
||||
$forall (Down d, es) <- Map.toList changelogEntries
|
||||
<dt .deflist__dt ##{"changelog-date--" <> toPathPiece d}>
|
||||
^{formatTimeW SelFormatDate d}
|
||||
<dd .deflist__dd>
|
||||
<ul>
|
||||
$forall e <- Set.toList es
|
||||
<li ##{"changelog-item--" <> toPathPiece e}>
|
||||
$if is _ChangelogItemBugfix $ classifyChangelogItem e
|
||||
<i>
|
||||
_{ChangelogItemBugfix}
|
||||
: #
|
||||
^{changelogItems ! toPathPiece e}
|
||||
@ -20,6 +20,9 @@ $maybe desc <- examDescription
|
||||
#{desc}
|
||||
|
||||
<section>
|
||||
$maybe warn <- notificationDiscouragedExamMode
|
||||
^{warn}
|
||||
|
||||
<dl .deflist>
|
||||
$if not examVisible
|
||||
<dt .deflist__dt>_{MsgExamVisibleFrom}
|
||||
@ -41,6 +44,41 @@ $maybe desc <- examDescription
|
||||
$maybe publishAssignments <- examPublishOccurrenceAssignments
|
||||
<dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
|
||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
|
||||
$maybe online <- examOnline examExamMode
|
||||
<dt .deflist__dt>_{MsgExamShowOnline}
|
||||
<dd .deflist__dd>
|
||||
$case online
|
||||
$of ExamOnlinePreset p
|
||||
^{examOnlinePresetWidget p}
|
||||
$of ExamOnlineCustom c
|
||||
#{c}
|
||||
$maybe synchronicity <- examSynchronicity examExamMode
|
||||
<dt .deflist__dt>_{MsgExamShowSynchronicity}
|
||||
<dd .deflist__dd>
|
||||
$case synchronicity
|
||||
$of ExamSynchronicityPreset p
|
||||
^{examSynchronicityPresetWidget p}
|
||||
$of ExamSynchronicityCustom c
|
||||
#{c}
|
||||
$maybe aids <- examAids examExamMode
|
||||
<dt .deflist__dt>_{MsgExamShowAids}
|
||||
<dd .deflist__dd>
|
||||
$case aids
|
||||
$of ExamAidsPreset p
|
||||
^{examAidsPresetWidget p}
|
||||
$of ExamAidsCustom c
|
||||
#{c}
|
||||
$maybe requiredEquipment <- examRequiredEquipment examExamMode
|
||||
<dt .deflist__dt>_{MsgExamShowRequiredEquipment}
|
||||
<dd .deflist__dd>
|
||||
<p>
|
||||
$case requiredEquipment
|
||||
$of ExamRequiredEquipmentPreset p
|
||||
^{examRequiredEquipmentPresetWidget p}
|
||||
$of ExamRequiredEquipmentCustom c
|
||||
#{c}
|
||||
|
||||
^{notificationPersonalIdentification}
|
||||
$maybe room <- examRoom
|
||||
<dt .deflist__dt>_{MsgExamRoom}
|
||||
<dd .deflist__dd>#{room}
|
||||
@ -89,6 +127,8 @@ $maybe desc <- examDescription
|
||||
_{MsgExamRegistration}
|
||||
<dd .deflist__dd>
|
||||
^{registerWdgt}
|
||||
$if is _Nothing (examRequiredEquipment examExamMode)
|
||||
^{notificationPersonalIdentification}
|
||||
|
||||
$if showCloseWidget && is _Nothing examClosed
|
||||
<section>
|
||||
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
Kursassoziierte Studienfächer wurden abgeschafft.
|
||||
<br>
|
||||
Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
Abolished course-associated features of study.
|
||||
<br>
|
||||
In course-related contexts now all study features which were up to date during the relevant term are displayed.
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Benutzer können sich in der Testphase komplett selbst löschen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
During testing users may completely delete their accounts
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Zusätzliche Uhrzeit- und Datumsformate
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Additional date and time formats
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Zusätzliche Benachrichtigungen für Übungsblätter
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Additional notifications for exercise sheets
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Bewerbungen für Zentralanmeldungen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Applications for central allocations
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kurse zu Zentralanmeldungen eintragen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Registration of courses for central allocation
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Notifications for new courses being added to central allocations
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Benachrichtigungen für Zentralanmeldungen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Notifications for central allocations
|
||||
2
templates/i18n/changelog/asidenav.de-de-formal.hamlet
Normal file
2
templates/i18n/changelog/asidenav.de-de-formal.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Designänderungen
|
||||
2
templates/i18n/changelog/asidenav.en-eu.hamlet
Normal file
2
templates/i18n/changelog/asidenav.en-eu.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Design changes
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Liste zugewiesener Abgaben lassen sich nun filtern
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Filters for list of assigned corrections
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Automatische Anmeldung von Bewerbern in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung)
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Option to automatically accept applications for courses outside of central allocations
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Besseres Verschicken von Kursmitteilungen an Tutoriumsteilnehmer
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Better sending of course communications to tutorial participants
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Submissions, tutorials, and exams are now shown on the detail page for course participants
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Verbesserter Workflow & Fehlerbehandlung für CSV-Import
|
||||
2
templates/i18n/changelog/better-csv-import.en-eu.hamlet
Normal file
2
templates/i18n/changelog/better-csv-import.en-eu.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Improved workflow and error-handling for CSV-import
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Verbesserte Handhabung von Datei-Uploads
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Improved handling of file uploads
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Verbesserte Farbkodierung von Tabellenzellen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Improved colour coding of table cells
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Multiple buttons/forms no work again when JavaScript is enabled
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Wählbares Format für Datum
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Configurable date and time formats
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Anpassbare angezeigte E-Mail Adressen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Configulable display emails
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Anpassbare angezeigte Namen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Configurable display names
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Viele Verbesserung zur Anzeige von Korrekturen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Numerous improvements for display of corrections
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Anzeige von Korrektoren auf den Kursseiten
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Display of correctors on course overview pages
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Configuration of course correctors and administrators without existing accounts
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Course administrators can now configure course administrators and assistants themselves
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Course enrollment requires association of a field of study (for students with multiple fields)
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt)
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Convenience links (i.e. current exercise sheet)
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kursliste über alle Semester hinweg (Top-Level-Navigation "Kurse"), wird in Zukunft Filter/Suchfunktion erhalten
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Overall course list for all semesters (see "Courses"), will have filters and search functions in the future
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Kursmaterial
|
||||
2
templates/i18n/changelog/course-materials.en-eu.hamlet
Normal file
2
templates/i18n/changelog/course-materials.en-eu.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Course material
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Versand von Benachrichtigungen an Kursteilnehmer
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user