fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into feat/exercises

Browse Source
This commit is contained in:
SJost 2018-06-22 07:55:36 +02:00
commit a3afbbc26d
13 changed files with 87 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
messages/de.msg
View File

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

12
routes
View File

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

24
src/CryptoID.hs
View File

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

7
src/Foundation.hs
View File

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

6
src/Handler/Course.hs
View File

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

23
src/Handler/CryptoIDDispatch.hs
View File

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

2
src/Handler/Sheet.hs
View File

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

9
src/Handler/Submission.hs
View File

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

12
src/Handler/Utils/Form.hs
View File

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

10
src/Model/Types.hs
View File

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

10
src/Utils.hs
View File

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

2
templates/sheetShow.hamlet
View File

@ -13,7 +13,7 @@
<h2 #description>Hinweise
<p> #{descr}
<h3>Bewertung
<p> #{show $ sheetType sheet}
<p> #{display $ sheetType sheet}
$maybe marking <- sheetMarkingText sheet
<p> #{marking}
<br>

2
templates/submission.hamlet
View File

@ -46,7 +46,7 @@
#{fileTitle file}&nbsp;
<span .label .label-warning>Gelöscht
$else
<a href=@{SubmissionDownloadSingleR cID $ fileTitle file} download .list-group-item>
<a href=@{SubmissionDownloadSingleR cID' $ fileTitle file} download .list-group-item>
#{fileTitle file}
$if submissionFileIsUpdate sFile
&nbsp;