Create new exams

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
+OccurrenceStart: Beginn
-OccurenceEnd: Ende
+OccurrenceEnd: Ende
 ScheduleExists: Dieser Plan existiert bereits
 
 ScheduleExceptions: Termin-Ausnahmen
@@ -1013,3 +1022,76 @@ CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "i
 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
+
+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

models/exams

@@ -1,18 +1,18 @@
 Exam
   course CourseId
-  name (CI Text)
+  name ExamName
-  gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ...
+  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
+  UniqueExamCorrector exam user
+ExamPartCorrector
+  part ExamPartId
+  corrector ExamCorrector
+  UniqueExamPartCorrector part corrector

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

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

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

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

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

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")

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

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

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 :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
-pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
+pointsField = checkBool (>= 0) MsgPointsNotPositive fixedPrecField
-  where
-    fieldEnctype = UrlEncoded
-    fieldView theId name attrs val isReq
-      = [whamlet|
-          $newline never
-          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
-        |]
-    fieldParse = parseHelper $ \t -> do
-      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
-      return . fromRational $ round (sci * 100) % 100
 
-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

src/Handler/Utils/Form/Occurrences.hs

@@ -1,5 +1,5 @@
-module Handler.Utils.Form.Occurences
+module Handler.Utils.Form.Occurrences
-  ( occurencesAForm
+  ( 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 Universe OccurrenceScheduleKind
-instance Finite OccurenceScheduleKind
+instance Finite OccurrenceScheduleKind
 
-nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2
+nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''OccurenceScheduleKind id
+embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id
 
-data OccurenceExceptionKind = ExceptionKindOccur
+data OccurrenceExceptionKind = ExceptionKindOccur
-                            | ExceptionKindNoOccur
+                             | ExceptionKindNoOccur
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
-instance Universe OccurenceExceptionKind
+instance Universe OccurrenceExceptionKind
-instance Finite OccurenceExceptionKind
+instance Finite OccurrenceExceptionKind
 
-nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
+nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
+embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id
 
 
-occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences
+occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences
-occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
+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' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule])
-        miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do
+        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 MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) 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' :: MassInputLayout ListLength OccurrenceSchedule ()
-        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout")
+        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' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException])
-        miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
+        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 MsgOccurrenceStart & addName (nudge "occur-start")) Nothing
-                                <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) 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' :: OccurrenceException -> Widget
-        miCell' ExceptOccur{..} = do
+        miCell' ExceptOccurr{..} = do
           exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
           exceptEnd'   <- formatTime SelFormatTime     exceptEnd
-          $(widgetFile "widgets/occurence/form/except-occur")
+          $(widgetFile "widgets/occurrence/form/except-occur")
-        miCell' ExceptNoOccur{..} = do
+        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' :: MassInputLayout ListLength OccurrenceException ()
-        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout")
+        miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout")
 
-  aFormToWForm $ Occurences
+  aFormToWForm $ Occurrences
     <$> scheduled
     <*> exceptions

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
+occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a
-occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do
+occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do
-  let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case
+  let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
         ScheduleWeekly{..} -> do
           scheduleStart' <- formatTime SelFormatTime scheduleStart
           scheduleEnd' <- formatTime SelFormatTime scheduleEnd
-          $(widgetFile "widgets/occurence/cell/weekly")
+          $(widgetFile "widgets/occurrence/cell/weekly")
-      occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case
+      occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
-        ExceptOccur{..} -> do
+        ExceptOccurr{..} -> do
           exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
           exceptEnd'   <- formatTime SelFormatTime     exceptStart
-          $(widgetFile "widgets/occurence/cell/except-occur")
+          $(widgetFile "widgets/occurrence/cell/except-occurr")
-        ExceptNoOccur{..} -> do
+        ExceptNoOccurr{..} -> do
           exceptTime' <- formatTime SelFormatDateTime exceptTime
-          $(widgetFile "widgets/occurence/cell/except-no-occur")
+          $(widgetFile "widgets/occurrence/cell/except-no-occurr")
-  $(widgetFile "widgets/occurence/cell")
+  $(widgetFile "widgets/occurrence/cell")

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

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
+data OccurrenceSchedule = ScheduleWeekly
-                         { scheduleDayOfWeek :: WeekDay
+                          { scheduleDayOfWeek :: WeekDay
-                         , scheduleStart     :: TimeOfDay
+                          , scheduleStart     :: TimeOfDay
-                         , scheduleEnd       :: 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
+data OccurrenceException = ExceptOccurr
-                          { exceptDay   :: Day
+                           { exceptDay   :: Day
-                          , exceptStart :: TimeOfDay
+                           , exceptStart :: TimeOfDay
-                          , exceptEnd   :: TimeOfDay
+                           , exceptEnd   :: TimeOfDay
-                          }
+                           }
-                        | ExceptNoOccur
+                         | ExceptNoOccurr
-                          { exceptTime  :: LocalTime
+                           { 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
+data Occurrences = Occurrences
-  { occurencesScheduled  :: Set OccurenceSchedule
+  { occurrencesScheduled  :: Set OccurrenceSchedule
-  , occurencesExceptions :: Set OccurenceException
+  , occurrencesExceptions :: Set OccurrenceException
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
-  } ''Occurences
+  } ''Occurrences
-derivePersistFieldJSON ''Occurences
+derivePersistFieldJSON ''Occurrences
 

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
+data ExamOccurrenceRule = ExamRoomManual
-                       | ExamRoomSurname
+                        | ExamRoomSurname
-                       | ExamRoomMatriculation
+                        | ExamRoomMatriculation
-                       | ExamRoomRandom
+                        | ExamRoomRandom
   deriving (Show, Read, Eq, Ord, Generic, Typeable)
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 2
   , fieldLabelModifier = camelToPathPiece' 1
   , sumEncoding = TaggedObject "rule" "settings"
-  } ''ExamOccurenceRule
+  } ''ExamOccurrenceRule
-derivePersistFieldJSON ''ExamOccurenceRule
+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

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
+          <input id=#{theId} name=#{name} *{attrs} type=number :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
+        |]
+    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
+          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :isReq:required value=#{either id (pack . showFixed True) val}>
+        |]
+    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 --
 -----------

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
 

src/Utils/Occurrences.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
 
-module Utils.Occurences
+module Utils.Occurrences
-  ( normalizeOccurences
+  ( 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)
+            throwE =<< asks (over _occurrencesExceptions $ Set.delete needle)
-        needle@ExceptOccur{..} -> do
+        needle@ExceptOccurr{..} -> do
           let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay
               -- | Does this ExceptNoOccur target within needle?
-              withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime
+              withinNeedle ExceptNoOccurr{..} = LocalTime exceptDay exceptStart <= exceptTime
-                                            && exceptTime <= LocalTime exceptDay exceptEnd
+                                             && 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)

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
       |]

templates/exam-list.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{examTable}

templates/exam-new.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{newExamForm}

templates/widgets/gradingKey.hamlet

@@ -0,0 +1,15 @@
+$newline never
+<table>
+  <thead>
+    <tr>
+      <td>
+      $forall g <- grades
+        <th>
+          _{g}
+  <tbody>
+    <tr>
+      <th>
+        _{MsgGradingFrom}
+      $forall (_, fv) <- bounds
+        <td>
+          ^{fvInput fv}

templates/widgets/massinput/examCorrectors/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/examCorrectors/cellInvitation.hamlet

@@ -0,0 +1,9 @@
+$newline never
+<td>
+  <span style="font-family: monospace">
+    #{email}
+<td>
+  <div .tooltip>
+    <div .tooltip__handle>
+    <div .tooltip__content>
+      _{MsgEmailInvitationWarning}

templates/widgets/massinput/examCorrectors/cellKnown.hamlet

@@ -0,0 +1,3 @@
+$newline never
+<td colspan=2>
+  ^{nameEmailWidget userEmail userDisplayName userSurname}

templates/widgets/massinput/examParts/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/examParts/form.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<td>#{csrf}^{fvInput epfNameView}
+<td>^{fvInput epfMaxPointsView}
+<td>^{fvInput epfWeightView}

templates/widgets/massinput/examParts/layout.hamlet

@@ -0,0 +1,16 @@
+$newline never
+<table>
+  <thead>
+    <th>_{MsgExamPartName}
+    <th>_{MsgExamPartMaxPoints}
+    <th>_{MsgExamPartWeight}
+    <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/massinput/examRooms/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/examRooms/form.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td>#{csrf}^{fvInput eofRoomView}
+<td>^{fvInput eofCapacityView}
+<td>^{fvInput eofStartView}
+<td>^{fvInput eofEndView}
+<td>^{fvInput eofDescView}

templates/widgets/massinput/examRooms/layout.hamlet

@@ -0,0 +1,18 @@
+$newline never
+<table>
+  <thead>
+    <th>_{MsgExamRoom}
+    <th>_{MsgExamRoomCapacity}
+    <th>_{MsgExamRoomStart}
+    <th>_{MsgExamRoomEnd}
+    <th>_{MsgExamRoomDescription}
+    <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/massinput/uploadSpecificFiles/layout.hamlet

@@ -4,7 +4,7 @@ $newline never
     <th>_{MsgUploadSpecificFileLabel}
     <th>_{MsgUploadSpecificFileName}
     <th>_{MsgUploadSpecificFileRequired}
-    <th>
+    <td>
   <tbody>
     $forall coord <- review liveCoords lLength
       <tr .massinput__cell>

templates/widgets/occurrence/cell.hamlet

@@ -1,12 +1,12 @@
 $newline never
 <ul .list--inline .list--iconless .list--comma-separated>
-  $forall sched <- occurencesScheduled'
+  $forall sched <- occurrencesScheduled'
     <li>^{sched}
 
-$if not (null occurencesExceptions)
+$if not (null occurrencesExceptions)
   $# <div .tooltip>
   $#   <div .tooltip__handle .tooltip__handle--danger>
   $#   <div .tooltip__content>
       <ul>
-        $forall exc <- occurencesExceptions'
+        $forall exc <- occurrencesExceptions'
           <li>^{exc}

templates/widgets/occurrence/form/except-layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/occurrence/form/scheduled-add.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td colspan=2>
+  ^{addWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/occurrence/form/scheduled-layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

test/Database.hs

@@ -586,9 +586,9 @@ fillDb = do
     , tutorialType = "Tutorium"
     , tutorialCapacity = Just 30
     , tutorialRoom = "Hilbert-Raum"
-    , tutorialTime = Occurences
+    , tutorialTime = Occurrences
-      { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00)
+      { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00)
-      , occurencesExceptions = Set.empty
+      , 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
+    , tutorialTime = Occurrences
-      { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00)
+      { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00)
-      , occurencesExceptions = Set.empty
+      , occurrencesExceptions = Set.empty
       }
     , tutorialRegGroup = Just "tutorium"
     , tutorialRegisterFrom = Just now