diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 993bffa46..96791ae8b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -631,6 +631,8 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} +MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für Klausur #{examn} + MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} SheetGrading: Bewertung @@ -835,6 +837,8 @@ MenuAuthPreds: Authorisierungseinstellungen MenuTutorialDelete: Tutorium löschen MenuTutorialEdit: Tutorium editieren MenuTutorialComm: Mitteilung an Teilnehmer +MenuExamList: Klausuren +MenuExamNew: Neue Klausur anlegen AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -922,6 +926,11 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für # TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. +ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für Klausur #{examn} eingetragen +ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für Klausur #{examn} zu werden, abgelehnt +ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für Klausur #{examn} +ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein. + SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn} @@ -942,8 +951,8 @@ ScheduleRegular: Planmäßiger Termin ScheduleRegularKind: Plan WeekDay: Wochentag Day: Tag -OccurenceStart: Beginn -OccurenceEnd: Ende +OccurrenceStart: Beginn +OccurrenceEnd: Ende ScheduleExists: Dieser Plan existiert bereits ScheduleExceptions: Termin-Ausnahmen @@ -1012,4 +1021,77 @@ CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladunge CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet -CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen \ No newline at end of file +CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen + +ExamName: Name +ExamTime: Termin +ExamsHeading: Klausuren +ExamNameTip: Muss innerhalb der Veranstaltung eindeutig sein +ExamStart: Beginn +ExamEnd: Ende +ExamDescription: Beschreibung +ExamVisibleFrom: Sichtbar ab +ExamVisibleFromTip: Ohne Datum nie sichtbar und keine Anmeldung möglich +ExamRegisterFrom: Anmeldung ab +ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klausur anmelden können; ohne Datum ist keine Anmeldung möglich +ExamRegisterTo: Anmeldung bis +ExamDeregisterUntil: Abmeldung bis +ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um +ExamFinished: Bewertung abgeschlossen ab +ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden +ExamClosed: Noten stehen fest ab +ExamClosedTip: Zeitpunkt ab dem keine Änderungen an den Ergebnissen zulässig sind; Prüfungsämter bekommen Einsicht +ExamPublicStatistics: Statistik veröffentlichen +ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können? +ExamGradingRule: Notenberechnung +ExamGradingManual': Manuell +ExamGradingKey': Nach Schlüssel +ExamGradingKey: Notenschlüssel +ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden +Points: Punkte +PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein +PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein +GradingFrom: Ab +ExamNew: Neue Klausur +ExamBonusRule: Klausurbonus aus Übungsbetrieb +ExamNoBonus': Kein Bonus +ExamBonusPoints': Umrechnung von Übungspunkten + +ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte +ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein +ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen + +ExamOccurrenceRule: Automatische Terminzuteilung +ExamRoomManual': Keine automatische Zuteilung +ExamRoomSurname': Nach Nachname +ExamRoomMatriculation': Nach Matrikelnummer +ExamRoomRandom': Zufällig pro Teilnehmer + +ExamOccurrences: Prüfungen +ExamRoomAlreadyExists: Prüfung ist bereits eingetragen +ExamRoom: Raum +ExamRoomCapacity: Kapazität +ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein +ExamRoomStart: Beginn +ExamRoomEnd: Ende +ExamRoomDescription: Beschreibung +ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung + +ExamFormTimes: Zeiten +ExamFormOccurrences: Prüfungstermine +ExamFormAutomaticFunctions: Automatische Funktionen +ExamFormCorrection: Korrektur +ExamFormParts: Teile + +ExamCorrectors: Korrektoren +ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Klausur eingetragen + +ExamParts: Teilaufgaben +ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein +ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits +ExamPartName: Name +ExamPartMaxPoints: Maximalpunktzahl +ExamPartWeight: Gewichtung + +ExamNameTaken exam@ExamName: Es existiert bereits eine Klausur mit Namen #{exam} +ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt \ No newline at end of file diff --git a/models/exams b/models/exams index 7d61e2e6d..b6ed523e2 100644 --- a/models/exams +++ b/models/exams @@ -1,18 +1,18 @@ Exam course CourseId - name (CI Text) - gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ... + name ExamName + gradingRule ExamGradingRule bonusRule ExamBonusRule - occurrenceRule ExamOccurenceRule + occurrenceRule ExamOccurrenceRule visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe - publishOccurenceAssignments UTCTime + publishOccurrenceAssignments UTCTime start UTCTime end UTCTime Maybe finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out - closed Bool -- Prüfungsamt hat Einsicht (notification) + closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification) publicStatistics Bool description Html Maybe UniqueExam course name @@ -22,14 +22,17 @@ ExamPart maxPoints Points Maybe weight Rational UniqueExamPart exam name -ExamOccurence +ExamOccurrence exam ExamId room Text capacity Natural + start UTCTime + end UTCTime Maybe + description Html Maybe ExamRegistration exam ExamId user UserId - occurance ExamOccurenceId Maybe + occurance ExamOccurrenceId Maybe UniqueExamRegistration exam user ExamResult examPart ExamPartId @@ -37,6 +40,10 @@ ExamResult result ExamPartResult UniqueExamResult examPart user ExamCorrector - examPart ExamPartId + exam ExamId user UserId - UniqueExamCorrector examPart user \ No newline at end of file + UniqueExamCorrector exam user +ExamPartCorrector + part ExamPartId + corrector ExamCorrector + UniqueExamPartCorrector part corrector \ No newline at end of file diff --git a/models/tutorials b/models/tutorials index 4961e0bd5..166a8dbef 100644 --- a/models/tutorials +++ b/models/tutorials @@ -4,7 +4,7 @@ Tutorial json type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room Text - time Occurences + time Occurrences regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/routes b/routes index 31885f668..abed932c2 100644 --- a/routes +++ b/routes @@ -136,6 +136,10 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST + /exams CExamListR GET !development -- Missing permission checks on which exams can be shown + /exams/new CExamNewR GET POST + /exams/#ExamName ExamR: + /corrector-invite ECInviteR GET POST /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index ab612883c..3e20e6613 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -113,6 +113,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Exam -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index 4567440f8..dc3621858 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -181,6 +181,10 @@ pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> T pattern CTutorialR tid ssh csh tnm ptn = CourseR tid ssh csh (TutorialR tnm ptn) +pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX +pattern CExamR tid ssh csh tnm ptn + = CourseR tid ssh csh (ExamR tnm ptn) + pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -318,6 +322,9 @@ instance RenderMessage UniWorX StudyDegreeTerm where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX ExamGrade where + renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade + newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse @@ -1436,6 +1443,9 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CourseR tid ssh csh CExamListR) = return ("Klausuren", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) @@ -1876,6 +1886,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers @@ -2080,6 +2098,16 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CExamListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5abd1e624..c31b7048c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -360,7 +360,7 @@ getCShowR tid ssh csh = do ^{nameEmailWidget' tutor} |] , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs new file mode 100644 index 000000000..4f1c4917a --- /dev/null +++ b/src/Handler/Exam.hs @@ -0,0 +1,391 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Exam where + +import Import + +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Invitations +import Jobs.Queue + +import Utils.Lens + +import qualified Database.Esqueleto as E + +import Data.Map ((!)) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) +import Text.Blaze.Html.Renderer.String (renderHtml) + + +getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamListR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + + let + examDBTable = DBTable{..} + where + dbtSQLQuery exam = do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return exam + dbtRowKey = (E.^. ExamId) + dbtProj = return + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ toWidget examName + , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do + startT <- formatTime SelFormatDateTime examStart + endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd + [whamlet| + $newline never + #{startT} + $maybe endT' <- endT + \ – #{endT'} + |] + ] + dbtSorting = Map.fromList + [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) + , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "exams" + + examDBTableValidator = def + & defaultSorting [SortAscBy "time"] + ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading + $(widgetFile "exam-list") + + +instance IsInvitableJunction ExamCorrector where + type InvitationFor ExamCorrector = Exam + data InvitableJunction ExamCorrector = JunctionExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExamCorrector = InvDBDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector)) + (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..}) + +instance ToJSON (InvitableJunction ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData ExamCorrector) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +examCorrectorInvitationConfig :: InvitationConfig ExamCorrector +examCorrectorInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR + invitationResolveFor = do + Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute + fetchExamId tid csh ssh examn + invitationSubject Exam{..} _ = do + Course{..} <- get404 examCourse + return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName + invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ _ _ = pure JunctionExamCorrector + invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName + invitationUltDest Exam{..} _ = do + Course{..} <- get404 examCourse + return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR + +getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getECInviteR = postECInviteR +postECInviteR = invitationR examCorrectorInvitationConfig + + +data ExamForm = ExamForm + { efName :: ExamName + , efDescription :: Maybe Html + , efStart :: UTCTime + , efEnd :: Maybe UTCTime + , efVisibleFrom :: Maybe UTCTime + , efRegisterFrom :: Maybe UTCTime + , efRegisterTo :: Maybe UTCTime + , efDeregisterUntil :: Maybe UTCTime + , efPublishOccurrenceAssignments :: UTCTime + , efFinished :: Maybe UTCTime + , efClosed :: Maybe UTCTime + , efOccurrences :: Set ExamOccurrenceForm + , efPublicStatistics :: Bool + , efGradingRule :: ExamGradingRule + , efBonusRule :: ExamBonusRule + , efOccurrenceRule :: ExamOccurrenceRule + , efCorrectors :: Set (Either UserEmail UserId) + , efExamParts :: Set ExamPartForm + } + +data ExamOccurrenceForm = ExamOccurrenceForm + { eofRoom :: Text + , eofCapacity :: Natural + , eofStart :: UTCTime + , eofEnd :: Maybe UTCTime + , eofDescription :: Maybe Html + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +data ExamPartForm = ExamPartForm + { epfName :: ExamPartName + , epfMaxPoints :: Maybe Points + , epfWeight :: Rational + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamPartForm + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamOccurrenceForm + + +examForm :: Maybe ExamForm -> Form ExamForm +examForm template html = do + MsgRenderer mr <- getMsgRenderer + + flip (renderAForm FormStandard) html $ ExamForm + <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) + <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) + <* aformSection MsgExamFormTimes + <*> areq utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) + <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) + <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template) + <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template) + <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) + <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) + <*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate)) (efPublishOccurrenceAssignments <$> template) + <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) + <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) + <* aformSection MsgExamFormOccurrences + <*> examOccurrenceForm (efOccurrences <$> template) + <* aformSection MsgExamFormAutomaticFunctions + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) + <*> examGradingRuleForm (efGradingRule <$> template) + <*> bonusRuleForm (efBonusRule <$> template) + <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <* aformSection MsgExamFormCorrection + <*> examCorrectorsForm (efCorrectors <$> template) + <* aformSection MsgExamFormParts + <*> examPartsForm (efExamParts <$> template) + +examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) +examCorrectorsForm mPrev = wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + Just currentRoute <- getCurrentRoute + uid <- liftHandlerT requireAuthId + + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) + miAdd' nudge submitView csrf = do + (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing + let + addRes' + | otherwise + = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList oldDat + , not $ Set.null existing + -> FormFailure [mr MsgExamCorrectorAlreadyAdded] + | otherwise + -> FormSuccess $ Set.toList newDat + return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add")) + + corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User)) + corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do + E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser + E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return corrUser + + + miCell' :: Either UserEmail UserId -> Widget + miCell' (Left email) = + $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") + miCell' (Right userId) = do + User{..} <- liftHandlerT . runDB $ get404 userId + $(widgetFile "widgets/massinput/examCorrectors/cellKnown") + + miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout") + + fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) True (Set.toList <$> mPrev) + +examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) +examOccurrenceForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev + where + examOccurrenceForm' nudge mPrev csrf = do + (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) + (eofCapacityRes, eofCapacityView) <- mpreq (posIntFieldI MsgExamRoomCapacityNonPositive) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) + (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) + (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) + (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) + + return ( ExamOccurrenceForm + <$> eofRoomRes + <*> eofCapacityRes + <*> eofStartRes + <*> eofEndRes + <*> (assertM (not . null . renderHtml) <$> eofDescRes) + , $(widgetFile "widgets/massinput/examRooms/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examRooms/add")) + miCell' nudge dat = examOccurrenceForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout") + miIdent' :: Text + miIdent' = "exam-occurrences" + +examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) +examPartsForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev + where + examPartForm' nudge mPrev csrf = do + (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) + (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) + + return ( ExamPartForm + <$> epfNameRes + <*> epfMaxPointsRes + <*> epfWeightRes + , $(widgetFile "widgets/massinput/examParts/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examPartForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examParts/add")) + miCell' nudge dat = examPartForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") + miIdent' :: Text + miIdent' = "exam-parts" + +getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamNewR = postCExamNewR +postCExamNewR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm Nothing + + formResult newExamResult $ \ExamForm{..} -> do + insertRes <- runDBJobs $ do + insertRes <- insertUnique Exam + { examName = efName + , examCourse = cid + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = efClosed + , examPublicStatistics = efPublicStatistics + , examDescription = efDescription + } + whenIsJust insertRes $ \examid -> do + insertMany_ + [ ExamPart{..} + | ExamPartForm{..} <- Set.toList efExamParts + , let examPartExam = examid + examPartName = epfName + examPartMaxPoints = epfMaxPoints + examPartWeight = epfWeight + ] + + insertMany_ + [ ExamOccurrence{..} + | ExamOccurrenceForm{..} <- Set.toList efOccurrences + , let examOccurrenceExam = examid + examOccurrenceRoom = eofRoom + examOccurrenceCapacity = eofCapacity + examOccurrenceStart = eofStart + examOccurrenceEnd = eofEnd + examOccurrenceDescription = eofDescription + ] + + let (invites, adds) = partitionEithers $ Set.toList efCorrectors + insertMany_ [ ExamCorrector{..} + | examCorrectorUser <- adds + , let examCorrectorExam = examid + ] + sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + return insertRes + case insertRes of + Nothing -> addMessageI Error $ MsgExamNameTaken efName + Just _ -> do + addMessageI Success $ MsgExamCreated efName + redirect $ CourseR tid ssh csh CExamListR + + let heading = prependCourseTitle tid ssh csh MsgExamNew + + siteLayoutMsg heading $ do + setTitleI heading + let + newExamForm = wrapForm newExamWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR + , formEncoding = newExamEnctype + } + $(widgetFile "exam-new") diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2a98110c1..964dfa1b3 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Table.Cells import Handler.Utils.Delete import Handler.Utils.Communication -import Handler.Utils.Form.Occurences +import Handler.Utils.Form.Occurrences import Handler.Utils.Invitations import Jobs.Queue @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo @@ -275,7 +275,7 @@ data TutorialForm = TutorialForm , tfType :: CI Text , tfCapacity :: Maybe Int , tfRoom :: Text - , tfTime :: Occurences + , tfTime :: Occurrences , tfRegGroup :: Maybe (CI Text) , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime @@ -322,7 +322,7 @@ tutorialForm cid template html = do <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurencesAForm ("occurences" :: Text) (tfTime <$> template) + <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs new file mode 100644 index 000000000..249d98b73 --- /dev/null +++ b/src/Handler/Utils/Exam.hs @@ -0,0 +1,47 @@ +module Handler.Utils.Exam + ( fetchExamAux + , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam + ) where + +import Import + +import Database.Persist.Sql (SqlBackendCanRead) +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E +import Database.Esqueleto.Utils.TH + +import Utils.Lens + + +fetchExamAux :: ( SqlBackendCanRead backend + , E.SqlSelect b a + , MonadHandler m + , Typeable a + ) + => (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b) + -> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a +fetchExamAux prj tid ssh csh examn = + let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn) + in cachedBy cachId $ do + tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do + E.on $ course E.^. CourseId E.==. tut E.^. ExamCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. tut E.^. ExamName E.==. E.val examn + return $ prj tut course + case tutList of + [tut] -> return tut + _other -> notFound + +fetchExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> DB (Entity Exam) +fetchExam = fetchExamAux const + +fetchExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Exam) +fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn + +fetchCourseIdExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Key Exam) +fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn + +fetchCourseIdExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Entity Exam) +fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0b6850b24..ea6d929b3 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -19,7 +19,6 @@ import qualified Data.CaseInsensitive as CI -- import Yesod.Core import qualified Data.Text as T -- import Yesod.Form.Types -import Yesod.Form.Functions (parseHelper) import Yesod.Form.Bootstrap3 import Handler.Utils.Zip @@ -38,8 +37,6 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Control.Monad.Error.Class (MonadError(..)) -import Data.Scientific (Scientific) -import Text.Read (readMaybe) import Data.Either (partitionEithers) import Utils.Lens @@ -56,6 +53,9 @@ import Yesod.Core.Types (FileInfo(..)) import System.FilePath (isExtensionOf) import Data.Text.Lens (unpacked) +import Data.Char (isDigit) +import Text.Blaze (toMarkup) + import Handler.Utils.Form.MassInput ---------------------------- @@ -241,35 +241,28 @@ htmlField' = htmlField } natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i -natFieldI msg = checkBool (>= 0) msg intField +natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg intField natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField +natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer natIntField = natField posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -posIntField d = checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField +posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField + +posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i +posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg intField -- | Field to request integral number > 'm' minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField -pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions -pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} - where - fieldEnctype = UrlEncoded - fieldView theId name attrs val isReq - = [whamlet| - $newline never - - |] - fieldParse = parseHelper $ \t -> do - sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) - return . fromRational $ round (sci * 100) % 100 +pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points +pointsField = checkBool (>= 0) MsgPointsNotPositive fixedPrecField -pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions +pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points pointsFieldMax Nothing = pointsField pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField @@ -448,6 +441,137 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] +data ExamBonusRule' = ExamNoBonus' + | ExamBonusPoints' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamBonusRule' +instance Finite ExamBonusRule' + +nullaryPathPiece ''ExamBonusRule' $ camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamBonusRule' id + +classifyBonusRule :: ExamBonusRule -> ExamBonusRule' +classifyBonusRule = \case + ExamNoBonus -> ExamNoBonus' + ExamBonusPoints{} -> ExamBonusPoints' + +bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule +bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev + where + actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) + actions = Map.fromList + [ ( ExamNoBonus' + , pure ExamNoBonus + ) + , ( ExamBonusPoints' + , ExamBonusPoints + <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + ) + ] + +data ExamOccurrenceRule' = ExamRoomManual' + | ExamRoomSurname' + | ExamRoomMatriculation' + | ExamRoomRandom' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamOccurrenceRule' +instance Finite ExamOccurrenceRule' + +nullaryPathPiece ''ExamOccurrenceRule' $ camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id + +classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule' +classifyExamOccurrenceRule = \case + ExamRoomManual -> ExamRoomManual' + ExamRoomSurname -> ExamRoomSurname' + ExamRoomMatriculation -> ExamRoomMatriculation' + ExamRoomRandom -> ExamRoomRandom' + +examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule +examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule + where + reverseClassify = \case + ExamRoomManual' -> ExamRoomManual + ExamRoomSurname' -> ExamRoomSurname + ExamRoomMatriculation' -> ExamRoomMatriculation + ExamRoomRandom' -> ExamRoomRandom + +data ExamGradingRule' = ExamGradingManual' + | ExamGradingKey' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamGradingRule' +instance Finite ExamGradingRule' + +nullaryPathPiece ''ExamGradingRule' $ camelToPathPiece' 2 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamGradingRule' id + +classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule' +classifyExamGradingRule = \case + ExamGradingManual -> ExamGradingManual' + ExamGradingKey{} -> ExamGradingKey' + +examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule +examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ classifyExamGradingRule <$> prev + where + actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule) + actions = Map.fromList + [ ( ExamGradingManual' + , pure ExamGradingManual + ) + , ( ExamGradingKey' + , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev) + ) + ] + + + gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points] + gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do + MsgRenderer mr <- getMsgRenderer + + fvId <- maybe newIdent return fsId + fvName <- maybe newFormIdent return fsName + + let + grades :: [ExamGrade] + grades = universeF + + let boundsFS (Text.filter isDigit . toPathPiece -> g) = "" + & addPlaceholder (mr MsgPoints) + & addName (fvName <> "__" <> g) + & addId (fvId <> "__" <> g) + bounds <- forM grades $ \case + g@Grade50 -> mforced pointsField (boundsFS g) 0 + grade -> mpreq pointsField (boundsFS grade) $ preview (ix . pred $ fromEnum grade) =<< template + + let errors + | anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative] + | FormSuccess bounds' <- sequence $ map (view _1) bounds + , not $ monotone bounds' + = [mr MsgPointsMustBeMonotonic] + | otherwise + = [] + + return ( if + | null errors -> sequence . unsafeTail $ map fst bounds + | otherwise -> FormFailure errors + , FieldView + { fvLabel = toMarkup $ mr fsLabel + , fvTooltip = toMarkup . mr <$> fsTooltip + , fvId + , fvInput = $(widgetFile "widgets/gradingKey") + , fvErrors = if + | (e : _) <- errors -> Just $ toMarkup e + | otherwise -> Nothing + , fvRequired = True + } + ) + + where + monotone (x1:x2:xs) = x1 <= x2 && monotone (x2:xs) + monotone _ = True + + pseudonymWordField :: Field Handler PseudonymWord pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) where diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurrences.hs similarity index 59% rename from src/Handler/Utils/Form/Occurences.hs rename to src/Handler/Utils/Form/Occurrences.hs index da0e7733f..9fb8118e4 100644 --- a/src/Handler/Utils/Form/Occurences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -1,5 +1,5 @@ -module Handler.Utils.Form.Occurences - ( occurencesAForm +module Handler.Utils.Form.Occurrences + ( occurrencesAForm ) where import Import @@ -13,32 +13,32 @@ import qualified Data.Map as Map import Utils.Lens -data OccurenceScheduleKind = ScheduleKindWeekly +data OccurrenceScheduleKind = ScheduleKindWeekly deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceScheduleKind -instance Finite OccurenceScheduleKind +instance Universe OccurrenceScheduleKind +instance Finite OccurrenceScheduleKind -nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceScheduleKind id +nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id -data OccurenceExceptionKind = ExceptionKindOccur - | ExceptionKindNoOccur +data OccurrenceExceptionKind = ExceptionKindOccur + | ExceptionKindNoOccur deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceExceptionKind -instance Finite OccurenceExceptionKind +instance Universe OccurrenceExceptionKind +instance Finite OccurrenceExceptionKind -nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceExceptionKind id +nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id -occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences -occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do +occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences +occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute let - scheduled :: AForm Handler (Set OccurenceSchedule) + scheduled :: AForm Handler (Set OccurrenceSchedule) scheduled = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -47,16 +47,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__scheduled" :: Text) (fslI MsgScheduleRegular & setTooltip MsgMassInputTip) False - (Set.toList . occurencesScheduled <$> mPrev) + (Set.toList . occurrencesScheduled <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do newSched <- multiActionW (Map.fromList [ ( ScheduleKindWeekly , ScheduleWeekly <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -65,16 +65,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists] | otherwise -> FormSuccess $ pure newSched' - miCell' :: OccurenceSchedule -> Widget + miCell' :: OccurrenceSchedule -> Widget miCell' ScheduleWeekly{..} = do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/form/weekly") + $(widgetFile "widgets/occurrence/form/weekly") - miLayout' :: MassInputLayout ListLength OccurenceSchedule () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout") + miLayout' :: MassInputLayout ListLength OccurrenceSchedule () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/scheduled-layout") - exceptions :: AForm Handler (Set OccurenceException) + exceptions :: AForm Handler (Set OccurrenceException) exceptions = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -83,19 +83,19 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__exceptions" :: Text) (fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip])) False - (Set.toList . occurencesExceptions <$> mPrev) + (Set.toList . occurrencesExceptions <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do newExc <- multiActionW (Map.fromList [ ( ExceptionKindOccur - , ExceptOccur + , ExceptOccurr <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) , ( ExceptionKindNoOccur - , ExceptNoOccur + , ExceptNoOccurr <$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing ) ] @@ -106,18 +106,18 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | otherwise -> FormSuccess $ pure newExc' - miCell' :: OccurenceException -> Widget - miCell' ExceptOccur{..} = do + miCell' :: OccurrenceException -> Widget + miCell' ExceptOccurr{..} = do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd - $(widgetFile "widgets/occurence/form/except-occur") - miCell' ExceptNoOccur{..} = do + $(widgetFile "widgets/occurrence/form/except-occur") + miCell' ExceptNoOccurr{..} = do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/form/except-no-occur") + $(widgetFile "widgets/occurrence/form/except-no-occur") - miLayout' :: MassInputLayout ListLength OccurenceException () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout") + miLayout' :: MassInputLayout ListLength OccurrenceException () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout") - aFormToWForm $ Occurences + aFormToWForm $ Occurrences <$> scheduled <*> exceptions diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 620e6776b..a16d088c2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Text.Blaze (ToMarkup(..)) import Utils.Lens import Handler.Utils -import Utils.Occurences +import Utils.Occurrences import qualified Data.Set as Set @@ -248,19 +248,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurencesCell :: IsDBTable m a => Occurences -> DBCell m a -occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do - let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case +occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do + let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/cell/weekly") - occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case - ExceptOccur{..} -> do + $(widgetFile "widgets/occurrence/cell/weekly") + occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case + ExceptOccurr{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart - $(widgetFile "widgets/occurence/cell/except-occur") - ExceptNoOccur{..} -> do + $(widgetFile "widgets/occurrence/cell/except-occurr") + ExceptNoOccurr{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/cell/except-no-occur") - $(widgetFile "widgets/occurence/cell") + $(widgetFile "widgets/occurrence/cell/except-no-occurr") + $(widgetFile "widgets/occurrence/cell") diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 5ffbcfb07..94966e1c1 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -27,6 +27,8 @@ type SheetName = CI Text type MaterialName = CI Text type UserEmail = CI Email type TutorialName = CI Text +type ExamName = CI Text +type ExamPartName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 10783550e..aa0226c34 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -2,7 +2,7 @@ Module: Model.Types.DateTime Description: Time related types -Terms, Seasons, and Occurence schedules +Terms, Seasons, and Occurrence schedules -} module Model.Types.DateTime ( module Model.Types.DateTime @@ -152,11 +152,11 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 termYear = year term -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } +data OccurrenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -164,31 +164,31 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule + } ''OccurrenceSchedule -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } +data OccurrenceException = ExceptOccurr + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccurr + { exceptTime :: LocalTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException + } ''OccurrenceException -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException +data Occurrences = Occurrences + { occurrencesScheduled :: Set OccurrenceSchedule + , occurrencesExceptions :: Set OccurrenceException } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences + } ''Occurrences +derivePersistFieldJSON ''Occurrences diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 66abbe195..1f8d5876f 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -9,6 +9,8 @@ module Model.Types.Exam import Import.NoModel import Model.Types.Common +import Control.Lens + data ExamPartResult = ExamAttended { examPartResult :: Maybe Points } | ExamNoShow | ExamVoided @@ -23,7 +25,7 @@ derivePersistFieldJSON ''ExamPartResult data ExamBonusRule = ExamNoBonus | ExamBonusPoints - { bonusExchangeRate :: Rational + { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool } deriving (Show, Read, Eq, Ord, Generic, Typeable) @@ -34,14 +36,79 @@ deriveJSON defaultOptions } ''ExamBonusRule derivePersistFieldJSON ''ExamBonusRule -data ExamOccurenceRule = ExamRoomManual - | ExamRoomSurname - | ExamRoomMatriculation - | ExamRoomRandom +data ExamOccurrenceRule = ExamRoomManual + | ExamRoomSurname + | ExamRoomMatriculation + | ExamRoomRandom deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "rule" "settings" - } ''ExamOccurenceRule -derivePersistFieldJSON ''ExamOccurenceRule + } ''ExamOccurrenceRule +derivePersistFieldJSON ''ExamOccurrenceRule + +data ExamGrade + = Grade50 + | Grade40 + | Grade37 + | Grade33 + | Grade30 + | Grade27 + | Grade23 + | Grade20 + | Grade17 + | Grade13 + | Grade10 + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamGrade +instance Finite ExamGrade + +numberGrade :: Prism' Rational ExamGrade +numberGrade = prism toNumberGrade fromNumberGrade + where + toNumberGrade = \case + Grade50 -> 5.0 + Grade40 -> 4.0 + Grade37 -> 3.7 + Grade33 -> 3.3 + Grade30 -> 3.0 + Grade27 -> 2.7 + Grade23 -> 2.3 + Grade20 -> 2.0 + Grade17 -> 1.7 + Grade13 -> 1.3 + Grade10 -> 1.0 + fromNumberGrade = \case + 5.0 -> Right Grade50 + 4.0 -> Right Grade40 + 3.7 -> Right Grade37 + 3.3 -> Right Grade33 + 3.0 -> Right Grade30 + 2.7 -> Right Grade27 + 2.3 -> Right Grade23 + 2.0 -> Right Grade20 + 1.7 -> Right Grade17 + 1.3 -> Right Grade13 + 1.0 -> Right Grade10 + n -> Left n + +instance PathPiece ExamGrade where + toPathPiece = tshow . review numberGrade + fromPathPiece = finiteFromPathPiece + +pathPieceJSON ''ExamGrade +pathPieceJSONKey ''ExamGrade + +data ExamGradingRule + = ExamGradingManual + | ExamGradingKey + { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4.7@, @n2 <= p < n3 -> p ~ 4.3@, ..., @n11 <= p -> p ~ 1.0@ + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "rule" "settings" + } ''ExamGradingRule +derivePersistFieldJSON ''ExamGradingRule diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2e5f22004..7690db79c 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -34,6 +34,10 @@ import Web.PathPieces import Data.UUID +import Data.Ratio ((%)) +import Data.Fixed +import Data.Scientific + import Utils -- import Utils.Message -- import Utils.PathPiece @@ -41,6 +45,10 @@ import Utils import Data.Proxy +import Text.HTML.SanitizeXSS (sanitizeBalance) +import Text.Blaze (preEscapedText) +import Text.Blaze.Html.Renderer.Pretty (renderHtml) + @@ -444,8 +452,52 @@ optionsFinite = do } return . mkOptionList $ mkOption <$> universeF +fractionalField :: forall m a. + ( RealFrac a + , Monad m + , RenderMessage (HandlerSite m) FormMessage + ) => Field m a +-- | Form `Field` for any `Fractional` number +-- +-- Use more specific `Field`s (i.e. `fixedPrecField`) whenever they exist +fractionalField = Field{..} + where + scientific' :: Iso' a Scientific + scientific' = iso (fromRational . toRational) (fromRational . toRational) + + fieldEnctype = UrlEncoded + fieldView theId name attrs (fmap $ view scientific' -> val) isReq + = [whamlet| + $newline never + + |] + fieldParse = parseHelper $ \t -> + maybe (Left $ MsgInvalidNumber t) (Right . review scientific') (readMay t :: Maybe Scientific) + +fixedPrecField :: forall m p. + ( Monad m + , RenderMessage (HandlerSite m) FormMessage + , HasResolution p + ) => Field m (Fixed p) +fixedPrecField = Field{..} + where + resolution' :: Integer + resolution' = resolution $ Proxy @p + + step = showFixed True (fromRational $ 1 % resolution' :: Fixed p) + + fieldEnctype = UrlEncoded + fieldView theId name attrs val isReq + = [whamlet| + $newline never + + |] + fieldParse = parseHelper $ \t -> do + sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific) + return . fromRational $ round (sci * fromIntegral resolution') % resolution' + rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational -rationalField = convertField toRational fromRational doubleField +rationalField = fractionalField data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -471,6 +523,12 @@ secretJsonField = Field{..} |] fieldEnctype = UrlEncoded +htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html +htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField + where + sanitize :: Text -> m (Either FormMessage Html) + sanitize = return . Right . preEscapedText . sanitizeBalance + ----------- -- Forms -- ----------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b4cd5a572..955b7dcf6 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -111,18 +111,21 @@ makeLenses_ ''SubmissionMode makePrisms ''E.Value -makeLenses_ ''OccurenceSchedule +makeLenses_ ''OccurrenceSchedule -makePrisms ''OccurenceSchedule +makePrisms ''OccurrenceSchedule -makeLenses_ ''OccurenceException +makeLenses_ ''OccurrenceException -makePrisms ''OccurenceException +makePrisms ''OccurrenceException -makeLenses_ ''Occurences +makeLenses_ ''Occurrences makeLenses_ ''PredDNF +makeLenses_ ''ExamBonusRule +makeLenses_ ''ExamGradingRule + -- makeClassy_ ''Load diff --git a/src/Utils/Occurences.hs b/src/Utils/Occurrences.hs similarity index 65% rename from src/Utils/Occurences.hs rename to src/Utils/Occurrences.hs index 077d79250..6de64fac3 100644 --- a/src/Utils/Occurences.hs +++ b/src/Utils/Occurrences.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -module Utils.Occurences - ( normalizeOccurences +module Utils.Occurrences + ( normalizeOccurrences ) where import ClassyPrelude @@ -20,21 +20,21 @@ import Data.Time import Data.Time.Calendar.WeekDate -normalizeOccurences :: Occurences -> Occurences +normalizeOccurrences :: Occurrences -> Occurrences -- ^ -- -- - Removes unnecessary exceptions -- - Merges overlapping schedules -normalizeOccurences initial +normalizeOccurrences initial | Left new <- runReader (runExceptT go) initial - = normalizeOccurences new + = normalizeOccurrences new | otherwise = initial where - go :: ExceptT Occurences (Reader Occurences) () + go :: ExceptT Occurrences (Reader Occurrences) () -- Find some inconsistency and `throwE` a version without it go = do - scheduled <- view _occurencesScheduled + scheduled <- view _occurrencesScheduled forM_ scheduled $ \case a@ScheduleWeekly{} -> do let @@ -50,35 +50,35 @@ normalizeOccurences initial | otherwise = Nothing merge _ = Nothing - merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a + merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a case merges of [] -> return () - ((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) + ((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) - exceptions <- view _occurencesExceptions + exceptions <- view _occurrencesExceptions forM_ exceptions $ \case - needle@ExceptNoOccur{..} -> do + needle@ExceptNoOccurr{..} -> do let LocalTime{..} = exceptTime (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay - needed <- views _occurencesScheduled . any $ \case + needed <- views _occurrencesScheduled . any $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart <= localTimeOfDay , localTimeOfDay <= scheduleEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.delete needle) - needle@ExceptOccur{..} -> do + throwE =<< asks (over _occurrencesExceptions $ Set.delete needle) + needle@ExceptOccurr{..} -> do let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay -- | Does this ExceptNoOccur target within needle? - withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime - && exceptTime <= LocalTime exceptDay exceptEnd + withinNeedle ExceptNoOccurr{..} = LocalTime exceptDay exceptStart <= exceptTime + && exceptTime <= LocalTime exceptDay exceptEnd withinNeedle _ = False - needed <- views _occurencesScheduled . none $ \case + needed <- views _occurrencesScheduled . none $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart == exceptStart , scheduleEnd == exceptEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 2d9b8b860..f3b8e0e7b 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -5,7 +5,7 @@ module Utils.PathPiece , splitCamel , camelToPathPiece, camelToPathPiece' , tuplePathPiece - , pathPieceJSONKey + , pathPieceJSON, pathPieceJSONKey ) where import ClassyPrelude.Yesod @@ -25,6 +25,7 @@ import Numeric.Natural import Data.List (foldl) import Data.Aeson.Types +import qualified Data.Aeson.Types as Aeson finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a @@ -120,5 +121,14 @@ pathPieceJSONKey tName = [d| instance ToJSONKey $(conT tName) where toJSONKey = toJSONKeyText toPathPiece instance FromJSONKey $(conT tName) where - fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t + fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t + |] + +pathPieceJSON :: Name -> DecsQ +-- ^ Derive `ToJSON`- and `FromJSON`-Instances from a `PathPiece`-Instance +pathPieceJSON tName + = [d| instance ToJSON $(conT tName) where + toJSON = Aeson.String . toPathPiece + instance FromJSON $(conT tName) where + parseJSON = Aeson.withText $(TH.lift $ nameBase tName) $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t |] diff --git a/templates/exam-list.hamlet b/templates/exam-list.hamlet new file mode 100644 index 000000000..b39bba56d --- /dev/null +++ b/templates/exam-list.hamlet @@ -0,0 +1,2 @@ +$newline never +^{examTable} diff --git a/templates/exam-new.hamlet b/templates/exam-new.hamlet new file mode 100644 index 000000000..2b87f350b --- /dev/null +++ b/templates/exam-new.hamlet @@ -0,0 +1,2 @@ +$newline never +^{newExamForm} diff --git a/templates/widgets/gradingKey.hamlet b/templates/widgets/gradingKey.hamlet new file mode 100644 index 000000000..d6a95326b --- /dev/null +++ b/templates/widgets/gradingKey.hamlet @@ -0,0 +1,15 @@ +$newline never + + + + + +
+ $forall g <- grades + + _{g} +
+ _{MsgGradingFrom} + $forall (_, fv) <- bounds + + ^{fvInput fv} diff --git a/templates/widgets/massinput/examCorrectors/add.hamlet b/templates/widgets/massinput/examCorrectors/add.hamlet new file mode 100644 index 000000000..bdf6da247 --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput submitView} diff --git a/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet b/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet new file mode 100644 index 000000000..27c423ad1 --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet @@ -0,0 +1,9 @@ +$newline never + + + #{email} + +
+
+
+ _{MsgEmailInvitationWarning} diff --git a/templates/widgets/massinput/examCorrectors/cellKnown.hamlet b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet new file mode 100644 index 000000000..5ea4cca6f --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet @@ -0,0 +1,3 @@ +$newline never +
 + ^{nameEmailWidget userEmail userDisplayName userSurname} diff --git a/templates/widgets/occurence/form/scheduled-layout.hamlet b/templates/widgets/massinput/examCorrectors/layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-layout.hamlet rename to templates/widgets/massinput/examCorrectors/layout.hamlet diff --git a/templates/widgets/massinput/examParts/add.hamlet b/templates/widgets/massinput/examParts/add.hamlet new file mode 100644 index 000000000..6ef4903fb --- /dev/null +++ b/templates/widgets/massinput/examParts/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formWidget} + + ^{fvInput submitView} diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet new file mode 100644 index 000000000..2da5a3234 --- /dev/null +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -0,0 +1,4 @@ +$newline never +#{csrf}^{fvInput epfNameView} +^{fvInput epfMaxPointsView} +^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet new file mode 100644 index 000000000..87ab7fef4 --- /dev/null +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -0,0 +1,16 @@ +$newline never + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/examRooms/add.hamlet b/templates/widgets/massinput/examRooms/add.hamlet new file mode 100644 index 000000000..6ef4903fb --- /dev/null +++ b/templates/widgets/massinput/examRooms/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formWidget} +
_{MsgExamPartName} + _{MsgExamPartMaxPoints} + _{MsgExamPartWeight} + +
+ ^{fvInput (delButtons ! coord)} +
+ ^{fvInput submitView} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet new file mode 100644 index 000000000..a6bdff401 --- /dev/null +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -0,0 +1,6 @@ +$newline never +#{csrf}^{fvInput eofRoomView} +^{fvInput eofCapacityView} +^{fvInput eofStartView} +^{fvInput eofEndView} +^{fvInput eofDescView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet new file mode 100644 index 000000000..cc4211e5c --- /dev/null +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -0,0 +1,18 @@ +$newline never + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet index 2179c82b1..15911ac06 100644 --- a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet +++ b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet @@ -4,7 +4,7 @@ $newline never $forall coord <- review liveCoords lLength diff --git a/templates/widgets/occurence/cell.hamlet b/templates/widgets/occurrence/cell.hamlet similarity index 64% rename from templates/widgets/occurence/cell.hamlet rename to templates/widgets/occurrence/cell.hamlet index bb1f1f3d7..295b3ae24 100644 --- a/templates/widgets/occurence/cell.hamlet +++ b/templates/widgets/occurrence/cell.hamlet @@ -1,12 +1,12 @@ $newline never
    - $forall sched <- occurencesScheduled' + $forall sched <- occurrencesScheduled'
  • ^{sched} -$if not (null occurencesExceptions) +$if not (null occurrencesExceptions) $#
    $#
    $#
      - $forall exc <- occurencesExceptions' + $forall exc <- occurrencesExceptions'
    • ^{exc} diff --git a/templates/widgets/occurence/cell/except-no-occur.hamlet b/templates/widgets/occurrence/cell/except-no-occurr.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-no-occur.hamlet rename to templates/widgets/occurrence/cell/except-no-occurr.hamlet diff --git a/templates/widgets/occurence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occurr.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-occur.hamlet rename to templates/widgets/occurrence/cell/except-occurr.hamlet diff --git a/templates/widgets/occurence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/cell/weekly.hamlet rename to templates/widgets/occurrence/cell/weekly.hamlet diff --git a/templates/widgets/occurence/form/except-add.hamlet b/templates/widgets/occurrence/form/except-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-add.hamlet rename to templates/widgets/occurrence/form/except-add.hamlet diff --git a/templates/widgets/occurrence/form/except-layout.hamlet b/templates/widgets/occurrence/form/except-layout.hamlet new file mode 100644 index 000000000..65352dd95 --- /dev/null +++ b/templates/widgets/occurrence/form/except-layout.hamlet @@ -0,0 +1,11 @@ +$newline never +
_{MsgExamRoom} + _{MsgExamRoomCapacity} + _{MsgExamRoomStart} + _{MsgExamRoomEnd} + _{MsgExamRoomDescription} + +
+ ^{fvInput (delButtons ! coord)} +
_{MsgUploadSpecificFileLabel} _{MsgUploadSpecificFileName} _{MsgUploadSpecificFileRequired} - +
+ + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/occurence/form/except-no-occur.hamlet b/templates/widgets/occurrence/form/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-no-occur.hamlet rename to templates/widgets/occurrence/form/except-no-occur.hamlet diff --git a/templates/widgets/occurence/form/except-occur.hamlet b/templates/widgets/occurrence/form/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-occur.hamlet rename to templates/widgets/occurrence/form/except-occur.hamlet diff --git a/templates/widgets/occurrence/form/scheduled-add.hamlet b/templates/widgets/occurrence/form/scheduled-add.hamlet new file mode 100644 index 000000000..bcb16ecfa --- /dev/null +++ b/templates/widgets/occurrence/form/scheduled-add.hamlet @@ -0,0 +1,5 @@ +$newline never +
+ ^{fvInput (delButtons ! coord)} +
+ ^{addWidget} + + ^{fvInput submitView} diff --git a/templates/widgets/occurrence/form/scheduled-layout.hamlet b/templates/widgets/occurrence/form/scheduled-layout.hamlet new file mode 100644 index 000000000..65352dd95 --- /dev/null +++ b/templates/widgets/occurrence/form/scheduled-layout.hamlet @@ -0,0 +1,11 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/occurence/form/weekly.hamlet b/templates/widgets/occurrence/form/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/form/weekly.hamlet rename to templates/widgets/occurrence/form/weekly.hamlet diff --git a/test/Database.hs b/test/Database.hs index ea044ac75..f339ee6d0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -586,9 +586,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now @@ -604,9 +604,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now
+ ^{fvInput (delButtons ! coord)} +