feat(exams): CRU (no D) for exams

messages/uniworx/de.msg

@@ -839,6 +839,7 @@ MenuTutorialEdit: Tutorium editieren
 MenuTutorialComm: Mitteilung an Teilnehmer
 MenuExamList: Klausuren
 MenuExamNew: Neue Klausur anlegen
+MenuExamEdit: Bearbeiten
 
 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
@@ -979,6 +980,7 @@ TutorialsHeading: Tutorien
 TutorialEdit: Bearbeiten
 TutorialDelete: Löschen
 
+CourseExams: Klausuren
 CourseTutorials: Übungen
 
 ParticipantsN n@Int: Teilnehmer
@@ -1000,6 +1002,7 @@ TutorialNew: Neues Tutorium
 
 TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn}
 TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt
+TutorialEdited tutn@TutorialName: Tutiorium #{tutn} erfolgreich bearbeitet
 
 TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten
 
@@ -1037,10 +1040,14 @@ ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klaus
 ExamRegisterTo: Anmeldung bis
 ExamDeregisterUntil: Abmeldung bis
 ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um
+ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab
 ExamFinished: Bewertung abgeschlossen ab
+ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
 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
+ExamShowGrades: Noten anzeigen
+ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder sollen sie nur informiert werden, ob sie bestanden haben?
 ExamPublicStatistics: Statistik veröffentlichen
 ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können?
 ExamGradingRule: Notenberechnung
@@ -1057,11 +1064,14 @@ ExamBonusRule: Klausurbonus aus Übungsbetrieb
 ExamNoBonus': Kein Bonus
 ExamBonusPoints': Umrechnung von Übungspunkten
 
+ExamEditHeading examn@ExamName: #{examn} bearbeiten
+
 ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte
 ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein
 ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
 
 ExamOccurrenceRule: Automatische Terminzuteilung
+ExamOccurrenceRuleParticipant: Terminzuteilung
 ExamRoomManual': Keine automatische Zuteilung
 ExamRoomSurname': Nach Nachname
 ExamRoomMatriculation': Nach Matrikelnummer
@@ -1072,10 +1082,12 @@ ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
 ExamRoom: Raum
 ExamRoomCapacity: Kapazität
 ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein
+ExamRoomTime: Termin
 ExamRoomStart: Beginn
 ExamRoomEnd: Ende
 ExamRoomDescription: Beschreibung
 ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung
+ExamRoomRegistered: Zugeteilt
 
 ExamFormTimes: Zeiten
 ExamFormOccurrences: Prüfungstermine
@@ -1092,6 +1104,18 @@ ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits
 ExamPartName: Name
 ExamPartMaxPoints: Maximalpunktzahl
 ExamPartWeight: Gewichtung
+ExamPartResultPoints: Erreichte Punkte
 
 ExamNameTaken exam@ExamName: Es existiert bereits eine Klausur mit Namen #{exam}
-ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt
+ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt
+ExamEdited exam@ExamName: Klausur #{exam} erfolgreich bearbeitet
+
+ExamNoShow: Nicht erschienen
+ExamVoided: Entwertet
+
+ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Klausurpunkte
+ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Klausurpunkte, falls die Klausur auch ohne Bonus bereits bestanden ist
+
+ExamPassed: Bestanden
+ExamNotPassed: Nicht bestanden
+ExamResult: Klausurergebnis

models/exams

@@ -14,6 +14,7 @@ Exam
   finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out
   closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification)
   publicStatistics Bool
+  showGrades Bool
   description Html Maybe
   UniqueExam course name
 ExamPart
@@ -32,13 +33,18 @@ ExamOccurrence
 ExamRegistration
   exam ExamId
   user UserId
-  occurance ExamOccurrenceId Maybe
+  occurrence ExamOccurrenceId Maybe
   UniqueExamRegistration exam user
-ExamResult
+ExamPartResult
   examPart ExamPartId
   user UserId
-  result ExamPartResult
+  result ExamResultPoints
-  UniqueExamResult examPart user
+  UniqueExamPartResult examPart user
+ExamResult
+  exam ExamId
+  user UserId
+  result ExamResultGrade
+  UniqueExamResult exam user
 ExamCorrector
   exam ExamId
   user UserId

routes

@@ -141,6 +141,7 @@
   /exams/new                    CExamNewR      GET POST
   /exams/#ExamName ExamR:
     /show                       EShowR         GET             !time
+    /edit                       EEditR         GET POST
     /corrector-invite           ECInviteR      GET POST
 
 

src/CryptoID.hs

@@ -43,6 +43,8 @@ decCryptoIDs [ ''SubmissionId
              , ''SystemMessageId
              , ''SystemMessageTranslationId
              , ''StudyFeaturesId
+             , ''ExamOccurrenceId
+             , ''ExamPartId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Foundation.hs

@@ -1456,6 +1456,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
 
   breadcrumb (CExamR tid ssh csh examn EShowR) = return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
+  breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
 
   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)
@@ -1885,7 +1886,7 @@ pageActions (CourseR tid ssh csh CShowR) =
                         E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
                         E.&&.  course   E.^. CourseShorthand E.==. E.val csh
                     return $ sheet E.^. SheetName
-                  anyM sheetNames (sheetAccess . E.unValue)
+                  anyM sheetNames $ sheetAccess . E.unValue
           in runDB $ lecturerAccess `or2M` existsVisible
       }
   ] ++ pageActions (CourseR tid ssh csh SheetListR) ++
@@ -1903,7 +1904,18 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR
       , menuItemModal = False
-      , menuItemAccessCallback' = return True
+      , menuItemAccessCallback' =
+          let lecturerAccess   = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
+              examAccess examn = hasReadAccessTo  $ CExamR tid ssh csh examn EShowR
+              existsVisible = do
+                examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+                  E.on     $ course   E.^. CourseId E.==. exam 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
+                  return $ exam E.^. ExamName
+                anyM examNames $ examAccess . E.unValue
+           in runDB $ lecturerAccess `or2M` existsVisible
       }
   , MenuItem
       { menuItemType = PageActionSecondary
@@ -2119,6 +2131,16 @@ pageActions (CourseR tid ssh csh CExamListR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CExamR tid ssh csh examn EShowR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamEdit
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem
       { menuItemType = PageActionPrime

src/Handler/Course.hs

@@ -407,6 +407,49 @@ getCShowR tid ssh csh = do
       & defaultSorting [SortAscBy "type", SortAscBy "name"]
   (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
 
+  let
+    examDBTable = DBTable{..}
+      where
+        dbtSQLQuery exam = do
+          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+          return exam
+        dbtRowKey = (E.^. ExamId)
+        dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
+          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
+          return r
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName)
+          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
+          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
+          , 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 )
+          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
+          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
+          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exams"
+
+    examDBTableValidator = def
+      & defaultSorting [SortAscBy "time"]
+  (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
+
   siteLayout (toWgt $ courseName course) $ do
     setTitleI $ prependCourseTitle tid ssh csh (""::Text)
     $(widgetFile "course")

src/Handler/Exam.hs

@@ -10,11 +10,12 @@ import Handler.Utils.Invitations
 import Handler.Utils.Table.Cells
 import Jobs.Queue
 
-import Utils.Lens
+import Utils.Lens hiding (parts)
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
-import Data.Map ((!))
+import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -22,6 +23,8 @@ import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 import Text.Blaze.Html.Renderer.String (renderHtml)
 
+import qualified Data.CaseInsensitive as CI
+
 
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
@@ -57,6 +60,9 @@ getCExamListR tid ssh csh = do
         dbtSorting = Map.fromList
           [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
           , ("time", SortColumn $ \exam -> exam E.^. ExamStart )
+          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
+          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
+          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
           ]
         dbtFilter = Map.empty
         dbtFilterUI = const mempty
@@ -147,6 +153,7 @@ data ExamForm = ExamForm
   , efFinished :: Maybe UTCTime
   , efClosed :: Maybe UTCTime
   , efOccurrences :: Set ExamOccurrenceForm
+  , efShowGrades :: Bool
   , efPublicStatistics :: Bool
   , efGradingRule :: ExamGradingRule
   , efBonusRule :: ExamBonusRule
@@ -156,7 +163,8 @@ data ExamForm = ExamForm
   }
 
 data ExamOccurrenceForm = ExamOccurrenceForm
-  { eofRoom :: Text
+  { eofId :: Maybe CryptoUUIDExamOccurrence
+  , eofRoom :: Text
   , eofCapacity :: Natural
   , eofStart :: UTCTime
   , eofEnd :: Maybe UTCTime
@@ -164,7 +172,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm
   } deriving (Read, Show, Eq, Ord, Generic, Typeable)
 
 data ExamPartForm = ExamPartForm
-  { epfName :: ExamPartName
+  { epfId :: Maybe CryptoUUIDExamPart
+  , epfName :: ExamPartName
   , epfMaxPoints :: Maybe Points
   , epfWeight :: Rational
   } deriving (Read, Show, Eq, Ord, Generic, Typeable)
@@ -198,6 +207,7 @@ examForm template html = do
     <*  aformSection MsgExamFormOccurrences
     <*> examOccurrenceForm (efOccurrences <$> template)
     <*  aformSection MsgExamFormAutomaticFunctions
+    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
     <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
     <*> examGradingRuleForm (efGradingRule <$> template)
     <*> bonusRuleForm (efBonusRule <$> template)
@@ -263,6 +273,7 @@ examOccurrenceForm prev = wFormToAForm $ do
   fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
   where
     examOccurrenceForm' nudge mPrev csrf = do
+      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
       (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)
@@ -270,7 +281,8 @@ examOccurrenceForm prev = wFormToAForm $ do
       (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
 
       return ( ExamOccurrenceForm
-                 <$> eofRoomRes
+                 <$> eofIdRes
+                 <*> eofRoomRes
                  <*> eofCapacityRes
                  <*> eofStartRes
                  <*> eofEndRes
@@ -301,12 +313,14 @@ examPartsForm prev = wFormToAForm $ do
   fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
   where
     examPartForm' nudge mPrev csrf = do
+      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
       (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
+                 <$> epfIdRes
+                 <*> epfNameRes
                  <*> epfMaxPointsRes
                  <*> epfWeightRes
              , $(widgetFile "widgets/massinput/examParts/form")
@@ -325,12 +339,114 @@ examPartsForm prev = wFormToAForm $ do
     miIdent' :: Text
     miIdent' = "exam-parts"   
 
+examFormTemplate :: Entity Exam -> DB ExamForm
+examFormTemplate (Entity eId Exam{..}) = do
+  parts <- selectList [ ExamPartExam ==. eId ] []
+  occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
+  correctors <- selectList [ ExamCorrectorExam ==. eId ] []
+  invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
+
+  parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
+  occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
+
+  return ExamForm
+    { efName             = examName
+    , efGradingRule      = examGradingRule
+    , efBonusRule        = examBonusRule
+    , efOccurrenceRule   = examOccurrenceRule
+    , efVisibleFrom      = examVisibleFrom
+    , efRegisterFrom     = examRegisterFrom
+    , efRegisterTo       = examRegisterTo
+    , efDeregisterUntil  = examDeregisterUntil
+    , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
+    , efStart            = examStart
+    , efEnd              = examEnd
+    , efFinished         = examFinished
+    , efClosed           = examClosed
+    , efShowGrades       = examShowGrades
+    , efPublicStatistics = examPublicStatistics
+    , efDescription      = examDescription
+    , efOccurrences      = Set.fromList $ do
+        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
+        return ExamOccurrenceForm
+          { eofId
+          , eofRoom        = examOccurrenceRoom
+          , eofCapacity    = examOccurrenceCapacity
+          , eofStart       = examOccurrenceStart
+          , eofEnd         = examOccurrenceEnd
+          , eofDescription = examOccurrenceDescription
+          }
+    , efExamParts        = Set.fromList $ do
+        (Just -> epfId, ExamPart{..}) <- parts'
+        return ExamPartForm
+          { epfId
+          , epfName      = examPartName
+          , epfMaxPoints = examPartMaxPoints
+          , epfWeight    = examPartWeight
+          }
+    , efCorrectors       = Set.unions
+      [ Set.fromList $ map Left invitations
+      , Set.fromList . map Right $ do
+          Entity _ ExamCorrector{..} <- correctors
+          return examCorrectorUser
+      ]
+    }
+
+examTemplate :: CourseId -> DB (Maybe ExamForm)
+examTemplate cid = runMaybeT $ do
+  newCourse <- MaybeT $ get cid
+  
+  [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+    E.where_ $ (       course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
+                 E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
+               )
+         E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
+    E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
+      E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
+      E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
+    E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
+    E.limit 1
+    E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
+    return (course, exam)
+
+  oldTerm <- MaybeT . get $ courseTerm oldCourse
+  newTerm <- MaybeT . get $ courseTerm newCourse
+
+  let
+    dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm 
+
+  return ExamForm
+    { efName             = examName oldExam
+    , efGradingRule      = examGradingRule oldExam
+    , efBonusRule        = examBonusRule oldExam
+    , efOccurrenceRule   = examOccurrenceRule oldExam
+    , efVisibleFrom      = dateOffset <$> examVisibleFrom oldExam
+    , efRegisterFrom     = dateOffset <$> examRegisterFrom oldExam
+    , efRegisterTo       = dateOffset <$> examRegisterTo oldExam
+    , efDeregisterUntil  = dateOffset <$> examDeregisterUntil oldExam
+    , efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam
+    , efStart            = dateOffset $ examStart oldExam
+    , efEnd              = dateOffset <$> examEnd oldExam
+    , efFinished         = dateOffset <$> examFinished oldExam
+    , efClosed           = dateOffset <$> examClosed oldExam
+    , efShowGrades       = examShowGrades oldExam
+    , efPublicStatistics = examPublicStatistics oldExam
+    , efDescription      = examDescription oldExam
+    , efOccurrences      = Set.empty
+    , efExamParts        = Set.empty
+    , efCorrectors       = Set.empty
+    }
+
 getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamNewR = postCExamNewR
 postCExamNewR tid ssh csh = do
-  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+  (cid, template) <- runDB $ do
+    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    template <- examTemplate cid
+    return (cid, template)
   
-  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm Nothing
+  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm template
 
   formResult newExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do
@@ -349,6 +465,7 @@ postCExamNewR tid ssh csh = do
         , examEnd                          = efEnd
         , examFinished                     = efFinished
         , examClosed                       = efClosed
+        , examShowGrades                   = efShowGrades
         , examPublicStatistics             = efPublicStatistics
         , examDescription                  = efDescription
         }
@@ -398,5 +515,179 @@ postCExamNewR tid ssh csh = do
         }
     $(widgetFile "exam-new")
 
+getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEEditR = postEEditR
+postEEditR tid ssh csh examn = do
+  (cid, eId, template) <- runDB $ do
+    (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
+
+    template <- examFormTemplate exam
+
+    return (cid, eId, template)
+
+  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . examForm $ Just template
+
+  formResult editExamResult $ \ExamForm{..} -> do
+    insertRes <- runDBJobs $ do
+      insertRes <- myReplaceUnique eId Exam
+        { examCourse           = cid
+        , examName             = efName
+        , 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
+        , examShowGrades       = efShowGrades
+        , examDescription      = efDescription
+        }
+
+      when (is _Nothing insertRes) $ do
+        occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
+        deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
+        forM_ (Set.toList efOccurrences) $ \case
+          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
+            ExamOccurrence
+              { examOccurrenceExam = eId
+              , examOccurrenceRoom = eofRoom
+              , examOccurrenceCapacity = eofCapacity
+              , examOccurrenceStart = eofStart
+              , examOccurrenceEnd = eofEnd
+              , examOccurrenceDescription = eofDescription
+              }
+          ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
+            cID <- hoistMaybe eofId
+            eofId' <- decrypt cID
+            oldOcc <- MaybeT $ get eofId'
+            guard $ examOccurrenceExam oldOcc == eId
+            lift $ replace eofId' ExamOccurrence
+              { examOccurrenceExam = eId
+              , examOccurrenceRoom = eofRoom
+              , examOccurrenceCapacity = eofCapacity
+              , examOccurrenceStart = eofStart
+              , examOccurrenceEnd = eofEnd
+              , examOccurrenceDescription = eofDescription
+              }
+
+
+        pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
+        deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
+        forM_ (Set.toList efExamParts) $ \case
+          ExamPartForm{ epfId = Nothing, .. } -> insert_
+            ExamPart
+              { examPartExam = eId
+              , examPartName = epfName
+              , examPartMaxPoints = epfMaxPoints
+              , examPartWeight = epfWeight
+              }
+          ExamPartForm{ .. } -> void . runMaybeT $ do
+            cID <- hoistMaybe epfId
+            epfId' <- decrypt cID
+            oldPart <- MaybeT $ get epfId'
+            guard $ examPartExam oldPart == eId
+            lift $ replace epfId' ExamPart
+              { examPartExam = eId
+              , examPartName = epfName
+              , examPartMaxPoints = epfMaxPoints
+              , examPartWeight = epfWeight
+              }
+
+
+        let (invites, adds) = partitionEithers $ Set.toList efCorrectors
+
+        deleteWhere [ ExamCorrectorExam ==. eId ]
+        insertMany_ $ map (ExamCorrector eId) adds
+
+        deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
+        sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
+
+      return insertRes
+
+    case insertRes of
+      Just _  -> addMessageI Error $ MsgExamNameTaken efName
+      Nothing -> do
+        addMessageI Success $ MsgExamEdited efName
+        redirect $ CExamR tid ssh csh efName EShowR
+
+  let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      editExamForm = wrapForm editExamWidget def
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
+        , formEncoding = editExamEnctype
+        }
+    $(widgetFile "exam-edit")
+    
+
 getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
-getEShowR = error "getExamShowR"
+getEShowR tid ssh csh examn = do
+  cTime <- liftIO getCurrentTime
+  mUid <- maybeAuthId
+  
+  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) <- runDB $ do
+    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
+
+    let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
+
+    let gradingVisible = NTop (Just cTime) >= NTop examFinished
+    gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments
+    occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
+
+    resultsRaw <- for mUid $ \uid ->
+      E.select . E.from $ \examPartResult -> do
+        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
+             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
+        return examPartResult
+    let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
+
+    result <- fmap join . for mUid $ getBy . UniqueExamResult eId
+
+    occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
+      E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
+      let
+        registered
+          | Just uid <- mUid
+          = E.exists . E.from $ \examRegistration -> do
+              E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
+                   E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+                   E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
+          | otherwise = E.false
+      E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
+      return (examOccurrence, registered)
+
+    let occurrences = map (over _2 E.unValue) occurrencesRaw
+
+    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences)
+
+  let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
+
+  let heading = prependCourseTitle tid ssh csh $ CI.original examName
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      gradingKeyW :: [Points] -> Widget
+      gradingKeyW bounds
+        = let boundWidgets :: [Widget]
+              boundWidgets = map (toWidget . (pack :: String -> Text) . showFixed True) bounds
+              grades :: [ExamGrade]
+              grades = universeF
+           in $(widgetFile "widgets/gradingKey")
+
+      examBonusW :: ExamBonusRule -> Widget
+      examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
+    $(widgetFile "exam-show")

src/Handler/Tutorial.hs

@@ -456,7 +456,7 @@ postTEditR tid ssh csh tutn = do
     case insertRes of
       Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
       Nothing -> do
-        addMessageI Success $ MsgTutorialCreated tfName
+        addMessageI Success $ MsgTutorialEdited tfName
         redirect $ CourseR tid ssh csh CTutorialListR
 
   let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template

src/Handler/Utils/Form.hs

@@ -559,7 +559,8 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
                { fvLabel   = toMarkup $ mr fsLabel
                , fvTooltip = toMarkup . mr <$> fsTooltip
                , fvId
-               , fvInput = $(widgetFile "widgets/gradingKey")
+               , fvInput = let boundWidgets = map (fvInput . snd) bounds
+                            in $(widgetFile "widgets/gradingKey")
                , fvErrors = if
                    | (e : _) <- errors -> Just $ toMarkup e
                    | otherwise -> Nothing

src/Model.hs

@@ -35,6 +35,7 @@ deriving instance Eq (Unique Course)    -- instance Eq TermSchoolCourseShort; in
 deriving instance Eq (Unique Sheet)     -- instance Eq CourseSheet
 deriving instance Eq (Unique Material)  -- instance Eq UniqueMaterial
 deriving instance Eq (Unique Tutorial)  -- instance Eq Tutorial
+deriving instance Eq (Unique Exam)
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Types/Exam.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 {-|
 Module: Model.Types.Exam
 Description: Types for modeling Exams
@@ -11,17 +13,17 @@ import Model.Types.Common
 
 import Control.Lens
 
-data ExamPartResult = ExamAttended { examPartResult :: Maybe Points }
+data ExamResult' res = ExamAttended { examResult :: res }
-                    | ExamNoShow
+                     | ExamNoShow
-                    | ExamVoided
+                     | ExamVoided
   deriving (Show, Read, Eq, Ord, Generic, Typeable)
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 1
   , omitNothingFields = True
   , sumEncoding = TaggedObject "status" "result"
-  } ''ExamPartResult
+  } ''ExamResult'
-derivePersistFieldJSON ''ExamPartResult
+derivePersistFieldJSON ''ExamResult'
 
 data ExamBonusRule = ExamNoBonus
                    | ExamBonusPoints
@@ -94,12 +96,15 @@ numberGrade = prism toNumberGrade fromNumberGrade
       n   -> Left  n
 
 instance PathPiece ExamGrade where
-  toPathPiece = tshow . review numberGrade
+  toPathPiece = tshow . (fromRational :: Rational -> Deci) . review numberGrade
   fromPathPiece = finiteFromPathPiece
 
 pathPieceJSON ''ExamGrade
 pathPieceJSONKey ''ExamGrade
 
+passingGrade :: ExamGrade -> Bool
+passingGrade = (>= Grade40)
+
 data ExamGradingRule
   = ExamGradingManual
   | ExamGradingKey
@@ -112,3 +117,6 @@ deriveJSON defaultOptions
   , sumEncoding = TaggedObject "rule" "settings"
   } ''ExamGradingRule
 derivePersistFieldJSON ''ExamGradingRule
+
+type ExamResultPoints = ExamResult' (Maybe Points)
+type ExamResultGrade = ExamResult' ExamGrade

src/Utils/Lens.hs

@@ -126,6 +126,8 @@ makeLenses_ ''PredDNF
 makeLenses_ ''ExamBonusRule
 makeLenses_ ''ExamGradingRule
 
+makeLenses_ ''UTCTime
+
 
 -- makeClassy_ ''Load
 

templates/course.hamlet

@@ -93,6 +93,10 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
       $else
         Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
         (z.B. Übungsblätter).
+  $if hasExams
+    <dt .deflist__dt>_{MsgCourseExams}
+    <dd .deflist__dd>
+      ^{examTable}
   $if hasTutorials
     <dt .deflist__dt>_{MsgCourseTutorials}
     <dd .deflist__dd>

templates/exam-edit.hamlet

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

templates/exam-show.cassius

@@ -0,0 +1,6 @@
+.occurrence--not-registered
+  text-decoration: strike-through;
+
+.result
+  padding-left: 2em;
+  font-size: 20px;

templates/exam-show.hamlet

@@ -0,0 +1,149 @@
+$newline never
+$maybe Entity _ ExamResult{examResultResult} <- result
+  $if gradingShown
+    <section>
+      <h2>
+        _{MsgExamResult}
+        $if gradingShown && not gradingVisible
+          \ ^{isVisible False}
+      <p .result>
+        $case examResultResult
+          $of ExamAttended grade
+            $if examShowGrades
+              _{grade}
+            $else
+              $if passingGrade grade
+                _{MsgExamPassed}
+              $else
+                _{MsgExamNotPassed}
+          $of ExamNoShow
+            _{MsgExamNoShow}
+          $of ExamVoided
+            _{MsgExamVoided}
+
+$maybe desc <- examDescription
+  <section>
+    #{desc}
+  
+<section>
+  <dl .deflist>
+    $if not examVisible
+      <dt .deflist__dt>_{MsgExamVisibleFrom}
+      <dd .deflist__dd>
+        $maybe from <- examVisibleFrom
+          ^{formatTimeW SelFormatDateTime from}
+        $nothing
+          _{MsgNever}
+        \ ^{isVisible False}
+    $maybe regFrom <- examRegisterFrom
+      <dt .deflist__dt>_{MsgExamRegisterFrom}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime regFrom}
+    $maybe regTo <- examRegisterTo
+      <dt .deflist__dt>_{MsgExamRegisterTo}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime regTo}
+    $maybe deregUntil <- examDeregisterUntil
+      <dt .deflist__dt>_{MsgExamDeregisterUntil}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime deregUntil}
+    <dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
+    <dd .deflist__dd>^{formatTimeW SelFormatDateTime examPublishOccurrenceAssignments}
+    $if examTimes
+      <dt .deflist__dt>_{MsgExamTime}
+      <dd .deflist__dd>
+        ^{formatTimeW SelFormatDateTime examStart}
+        $maybe end <- examEnd
+          \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
+    $maybe finished <- examFinished
+      <dt .deflist__dt>_{MsgExamFinishedParticipant}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime finished}
+    $if gradingShown
+      $if examGradingRule /= ExamGradingManual
+        <dt .deflist__dt>
+          _{MsgExamGradingRule}
+          $if not gradingVisible
+            \ ^{isVisible False}
+        <dd .deflist__dd>
+          $case examGradingRule
+            $of ExamGradingManual
+              _{MsgExamGradingManual'}
+            $of ExamGradingKey{..}
+              ^{gradingKeyW examGradingKey}
+      $if examBonusRule /= ExamNoBonus
+        <dt .deflist__dt>
+          _{MsgExamBonusRule}
+          $if not gradingVisible
+            \ ^{isVisible False}
+        <dd .deflist__dd>
+          ^{examBonusW examBonusRule}
+    $if occurrenceAssignmentsShown
+      <dt .deflist__dt>
+        _{MsgExamOccurrenceRuleParticipant}
+        $if not occurrenceAssignmentsVisible
+          \ ^{isVisible False}
+      <dd .deflist__dd>
+        $# TODO
+
+$if not (null occurrences)
+  <section>
+    <h2>
+      _{MsgExamOccurrences}
+    <table .table .table--striped .table--hover>
+      <thead>
+        <tr .table__row .table__row--head>
+          <th .table__th>_{MsgExamRoom}
+          $if not examTimes
+            <th .table__th>_{MsgExamRoomTime}
+          <th .table__th>_{MsgExamRoomDescription}
+          $if occurrenceAssignmentsShown
+            <th .table__th>
+              _{MsgExamRoomRegistered}
+              $if not occurrenceAssignmentsVisible
+                \ ^{isVisible False}
+      <tbody>
+        $forall (Entity _occId ExamOccurrence{examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences
+          <tr .table__row :occurrenceAssignmentsShown && not registered:.occurrence--not-registered>
+            <td .table__td>#{examOccurrenceRoom}
+            $if not examTimes
+              <td .table__td>
+                ^{formatTimeW SelFormatDateTime examOccurrenceStart}
+                $maybe end <- examOccurrenceEnd
+                  \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
+            <td .table__td>
+              $maybe desc <- examOccurrenceDescription
+                #{desc}
+            $if occurrenceAssignmentsShown
+              <td .table__td>
+                $if registered
+                  #{fontAwesomeIcon "check"}
+
+$if gradingShown && not (null parts)
+  <section>
+    <h2>
+      _{MsgExamParts}
+      $if gradingShown && not gradingVisible
+        \ ^{isVisible False}
+    <table .table .table--striped .table--hover >
+      <thead>
+        <tr .table__row .table__row--head>
+          <th .table__th>_{MsgExamPartName}
+          <th .table__th>_{MsgExamPartMaxPoints}
+          <th .table__th>_{MsgExamPartResultPoints}
+      <tbody>
+        $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- parts
+          <tr .table__row>
+            <td .table__td>#{examPartName}
+            <td .table__td>
+              $maybe mPoints <- examPartMaxPoints
+                #{showFixed True (fromRational examPartWeight * mPoints)}
+            <td .table__td>
+              $case fmap (examPartResultResult . entityVal) (results !? partId)
+                $of Nothing
+                $of Just (ExamAttended (Just ps))
+                  #{showFixed True ps}
+                $of Just (ExamAttended Nothing)
+                  #{fontAwesomeIcon "check"}
+                $of Just ExamNoShow
+                  _{MsgExamNoShow}
+                $of Just ExamVoided
+                  _{MsgExamVoided}
+
+$# TODO: Statistics

templates/widgets/bonusRule.hamlet

@@ -0,0 +1,8 @@
+$newline never
+$case bonusRule
+  $of ExamNoBonus
+    _{MsgExamNoBonus'}
+  $of ExamBonusPoints ps False
+    _{MsgExamBonusPoints ps}
+  $of ExamBonusPoints ps True
+    _{MsgExamBonusPointsPassed ps}

templates/widgets/gradingKey.hamlet

@@ -10,6 +10,6 @@ $newline never
     <tr>
       <th>
         _{MsgGradingFrom}
-      $forall (_, fv) <- bounds
+      $forall w <- boundWidgets
         <td>
-          ^{fvInput fv}
+          ^{w}

templates/widgets/massinput/examParts/form.hamlet

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

templates/widgets/massinput/examRooms/form.hamlet

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