diff --git a/messages/de.msg b/messages/de.msg
index d0fff6cb2..9ec04885d 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -32,8 +32,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.
@@ -56,7 +56,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.
CorrectionsTitle: Zugewiesene Korrekturen
diff --git a/routes b/routes
index 1b9668fbc..fe3059a9d 100644
--- a/routes
+++ b/routes
@@ -50,21 +50,23 @@
!/ex/new SheetNewR GET POST
/ex/#Text SheetR:
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
- /#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
+ !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST
/delete SDelR GET POST
!/sub/new SubmissionNewR GET POST !timeANDregistered
!/sub/own SubmissionOwnR GET !free
- !/sub/#CryptoUUIDSubmission SubmissionR GET POST !owner !corrector
+ !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector
/corrections CorrectionsR GET !free
-!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
-
-- TODO below
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
-!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
+!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated
/submission SubmissionListR GET !deprecated
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated
/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated
+-- TODO above
+
+!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
+!/*{CI FilePath} CryptoFileNameDispatchR GET !free
\ No newline at end of file
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index d13e98425..7019689ea 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -24,6 +24,8 @@ import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace
import System.FilePath.Cryptographic.ImplicitNamespace
+import qualified Data.Text as Text
+
import Data.UUID.Types
import Web.PathPieces
@@ -35,24 +37,33 @@ instance PathPiece UUID where
fromPathPiece = fromString . unpack
toPathPiece = pack . toString
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+ fromPathPiece = fmap CI.mk . fromPathPiece
+ toPathPiece = toPathPiece . CI.original
--- Generates CryptoUUID... Datatypes
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+ fromPathMultiPiece = Just . unpack . intercalate "/"
+ toPathMultiPiece = Text.splitOn "/" . pack
+
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+ fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+ toPathMultiPiece = toPathMultiPiece . CI.original
+
+
+-- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId
- , ''CourseId
- , ''SheetId
, ''FileId
- , ''UserId
]
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
-newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
+newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
deriving (Show, Read, Eq)
pattern NewSubmission :: SubmissionMode
pattern NewSubmission = SubmissionMode Nothing
-pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
+pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
pattern ExistingSubmission cID = SubmissionMode (Just cID)
instance PathPiece SubmissionMode where
@@ -62,6 +73,7 @@ instance PathPiece SubmissionMode where
toPathPiece (SubmissionMode Nothing) = "new"
toPathPiece (SubmissionMode (Just x)) = toPathPiece x
+
newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID)
deriving (Show, Read, Eq)
diff --git a/src/Foundation.hs b/src/Foundation.hs
index c770f110f..0879610e6 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/Course.hs b/src/Handler/Course.hs
index 2ae19143c..6e942e0be 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -142,12 +142,6 @@ postCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler False course
-getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
-getCourseEditIDR cID = do
- cIDKey <- getsYesod appCryptoIDKey
- courseID <- UUID.decrypt cIDKey cID
- courseEditHandler True =<< runDB (getEntity courseID)
-
courseDeleteHandler :: Handler Html -- not called anywhere yet
courseDeleteHandler = undefined
diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs
index da31ab516..3a711ff88 100644
--- a/src/Handler/CryptoIDDispatch.hs
+++ b/src/Handler/CryptoIDDispatch.hs
@@ -14,6 +14,7 @@
module Handler.CryptoIDDispatch
( getCryptoUUIDDispatchR
+ , getCryptoFileNameDispatchR
) where
import Import hiding (Proxy)
@@ -26,11 +27,25 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import qualified Control.Monad.Catch as E (Handler(..))
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
class CryptoRoute ciphertext plaintext where
cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
instance CryptoRoute UUID SubmissionId where
+ cryptoIDRoute _ (CryptoID -> cID) = do
+ (smid :: SubmissionId) <- decrypt cID
+ cID' <- encrypt smid
+ (tid,csh,shn) <- runDB $ do
+ shid <- submissionSheet <$> get404 smid
+ Sheet{..} <- get404 shid
+ Course{..} <- get404 sheetCourse
+ return (courseTerm, courseShorthand, sheetName)
+ return $ CSheetR tid csh shn $ SubmissionR cID'
+
+instance CryptoRoute (CI FilePath) SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do
(smid :: SubmissionId) <- decrypt cID
(tid,csh,shn) <- runDB $ do
@@ -39,7 +54,7 @@ instance CryptoRoute UUID SubmissionId where
Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName)
return $ CSheetR tid csh shn $ SubmissionR cID
-
+
class Dispatch ciphertext (x :: [*]) where
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
@@ -66,3 +81,9 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith
p :: Proxy '[ SubmissionId
]
p = Proxy
+
+getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
+getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectWith found302)
+ where
+ p :: Proxy '[ SubmissionId ]
+ p = Proxy
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/Handler/Submission.hs b/src/Handler/Submission.hs
index 3d738fe32..01b8d6a78 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -61,7 +61,7 @@ makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
flip (renderAForm FormStandard) html $ (,)
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
- <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) buddy
+ <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
])
@@ -79,7 +79,7 @@ getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
-getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html
+getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
getSubmissionR = postSubmissionR
postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
@@ -289,16 +289,15 @@ submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.a
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
return f
-getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
+getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
getSubmissionDownloadSingleR cID path = do
submissionID <- decrypt cID
- cID' <- encrypt submissionID
runDB $ do
isRating <- maybe False (== submissionID) <$> isRatingFile path
case isRating of
True -> do
- file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID)
+ file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 9182d4c34..9d5684a50 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -385,8 +385,8 @@ fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
fsl :: Text -> FieldSettings UniWorX
-fsl label =
- FieldSettings { fsLabel = (SomeMessage label)
+fsl lbl =
+ FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
@@ -394,8 +394,8 @@ fsl label =
}
fslp :: Text -> Text -> FieldSettings UniWorX
-fslp label placeholder =
- FieldSettings { fsLabel = (SomeMessage label)
+fslp lbl placeholder =
+ FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
@@ -403,8 +403,8 @@ fslp label placeholder =
}
fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
-fslpI label placeholder =
- FieldSettings { fsLabel = (SomeMessage label)
+fslpI lbl placeholder =
+ FieldSettings { fsLabel = (SomeMessage lbl)
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
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 @@
Hinweise
#{descr}
Bewertung
-
#{show $ sheetType sheet}
+
#{display $ sheetType sheet}
$maybe marking <- sheetMarkingText sheet
#{marking}
diff --git a/templates/submission.hamlet b/templates/submission.hamlet
index 469e076bb..0529e94aa 100644
--- a/templates/submission.hamlet
+++ b/templates/submission.hamlet
@@ -46,7 +46,7 @@
#{fileTitle file}
Gelöscht
$else
-
+
#{fileTitle file}
$if submissionFileIsUpdate sFile