diff --git a/messages/de.msg b/messages/de.msg index 3e14f73f8..47da259ef 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -29,8 +29,8 @@ SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. Unauthorized: Sie haben hierfür keine explizite Berechtigung. -UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}" -UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}" +UnauthorizedAnd l@Text r@Text: #{l} UND #{r} +UnauthorizedOr l@Text r@Text: #{l} ODER #{r} UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. @@ -52,7 +52,7 @@ SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termTo SubmissionMember g@Int: Mitabgebende(r) ##{tshow g} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe -SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. +SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt. EMail: E-Mail EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. diff --git a/src/Foundation.hs b/src/Foundation.hs index b175e2f9c..ffb4ba86d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -282,13 +282,14 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime + let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) case subRoute of - SFileR SheetExercise _ -> guard $ maybe False (<= cTime) sheetVisibleFrom + SFileR SheetExercise _ -> guard started SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR SheetMarking _ -> mzero -- only for correctors and lecturers - SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo - _ -> guard $ maybe False (<= cTime) sheetVisibleFrom + SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo + _ -> guard started return Authorized r -> do $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 3ec1ab090..bf51909af 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -160,7 +160,7 @@ getSheetList courseEnt = do [ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 - , headed "Bewertung" $ toWgt . show . sheetType . snd3 + , headed "Bewertung" $ toWgt . display . sheetType . snd3 ] let colAdmin = mconcat -- only show edit button for allowed course assistants [ headed "Korrigiert" $ toWgt . snd . trd3 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index cc913a5bc..bab4a2439 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -43,6 +43,9 @@ type Points = Centi toPoints :: Integral a => a -> Points toPoints = MkFixed . fromIntegral +pToI :: Points -> Integer +pToI = fromPoints -- TODO: do we want to multiply? + fromPoints :: Integral a => Points -> a fromPoints (MkFixed c) = fromInteger c @@ -52,6 +55,13 @@ data SheetType | Pass { maxPoints, passingPoints :: Points } | NotGraded deriving (Show, Read, Eq) + +instance DisplayAble SheetType where + display (Bonus {..}) = tshow (pToI maxPoints) <> " Bonuspunkte" + display (Normal{..}) = tshow (pToI maxPoints) <> " Punkte" + display (Pass {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow (pToI maxPoints) + display (NotGraded) = "Unbewertet" + deriveJSON defaultOptions ''SheetType derivePersistFieldJSON "SheetType" diff --git a/src/Utils.hs b/src/Utils.hs index 56e714d81..2ee4bd534 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -151,6 +151,16 @@ mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs +newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom + +instance Eq a => Eq (NTop (Maybe a)) where + (NTop x) == (NTop y) = x == y + +instance Ord a => Ord (NTop (Maybe a)) where + compare (NTop Nothing) (NTop Nothing) = EQ + compare (NTop Nothing) _ = GT + compare _ (NTop Nothing) = LT + compare (NTop (Just x)) (NTop (Just y)) = compare x y --------------- -- Exception -- diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 1ee760dff..61849ff6f 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -13,7 +13,7 @@
#{descr}
#{show $ sheetType sheet} +
#{display $ sheetType sheet} $maybe marking <- sheetMarkingText sheet
#{marking}