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

Submission upload (Sitzung mit Gregor)

Browse Source
This commit is contained in:
SJost 2018-04-10 12:50:20 +02:00
parent 4a7d35144a
commit a544c61be2
11 changed files with 110 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/de.msg
View File

@ -23,4 +23,6 @@ UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe

17
routes
View File

@ -20,17 +20,20 @@
/edit CourseEditR GET POST !lecturer
/ex SheetR !registered:
/ SheetListR GET
/#Text/show SheetShowR GET !time
/#Text/#SheetFileType/#FilePath SheetFileR GET !time
/new SheetNewR GET POST !lecturer
/#Text/edit SheetEditR GET POST !lecturer
/#Text/delete SheetDelR GET POST !lecturer
/ SheetListR GET
/#Text/show SheetShowR GET !time
/#Text/#SheetFileType/#FilePath SheetFileR GET !time
/new SheetNewR GET POST !lecturer
/#Text/edit SheetEditR GET POST !lecturer
/#Text/delete SheetDelR GET POST !lecturer
!/#Text/submission/#SubmissionMode SubmissionR GET POST !time
-- TODO below
/submission SubmissionListR GET POST
/submission/#CryptoUUIDSubmission SubmissionR GET POST
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST
/submissions.zip SubmissionDownloadMultiArchiveR POST
!/submission/archive/#FilePath SubmissionDownloadArchiveR GET
!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET

14
src/CryptoID.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
@ -37,3 +38,16 @@ decCryptoIDs [ ''SubmissionId
, ''FileId
]
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
deriving (Show, Read, Eq)
instance PathPiece SubmissionMode where
fromPathPiece "new" = Just $ SubmissionMode Nothing
fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s
toPathPiece (SubmissionMode Nothing) = "new"
toPathPiece (SubmissionMode (Just x)) = toPathPiece x

14
src/Foundation.hs
View File

@ -244,7 +244,7 @@ isAuthorizedDB route@(routeAttrs -> attrs) writeable
isAuthorizedDB UsersR _ = adminAccess Nothing
isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID
isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID
isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
isAuthorizedDB TermEditR _ = adminAccess Nothing
@ -254,10 +254,11 @@ isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entity
isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized --
isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID
isAuthorizedDB (CourseEditIDR cID) _ = do
courseId <- decrypt cID
courseLecturerAccess courseId
@ -339,9 +340,10 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR)
breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
breadcrumb HomeR = return ("UniworkY", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)

12
src/Handler/CryptoIDDispatch.hs
View File

@ -20,6 +20,8 @@ import Import hiding (Proxy)
import Data.Proxy
import Handler.Utils
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import qualified Control.Monad.Catch as E (Handler(..))
@ -30,9 +32,13 @@ class CryptoRoute ciphertext plaintext where
instance CryptoRoute UUID SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do
(_ :: SubmissionId) <- decrypt cID
return $ SubmissionR cID
(smid :: SubmissionId) <- decrypt cID
(tid,csh,shn) <- runDB $ do
shid <- submissionSheetId <$> get404 smid
Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourseId
return (courseTermId, courseShorthand, sheetName)
return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
class Dispatch ciphertext (x :: [*]) where

30
src/Handler/Sheet.hs
View File

@ -118,35 +118,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
] ]
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, Typeable a, MonadHandler m, IsPersistBackend backend
, PersistQueryRead backend, PersistUniqueRead backend
)
=> (E.SqlExpr (Entity Sheet) -> b)
-> Key Term -> Text -> Text -> ReaderT backend m a
fetchSheetAux prj tid csh shn =
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
in cachedBy cachId $ do
-- Mit Yesod:
-- cid <- getKeyBy404 $ CourseTermShort tid csh
-- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
E.where_ $ course E.^. CourseTermId E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet
case sheetList of
[sheet] -> return sheet
_other -> notFound
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id
fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
-- List Sheets
getSheetListCID :: CourseId -> Handler Html
@ -205,6 +177,7 @@ getSheetList courseEnt = do
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
else encodeWidgetTable tableDefault colSheets sheets
-- Show single sheet
getSheetShowR :: TermId -> Text -> Text -> Handler Html
getSheetShowR tid csh shn = do
@ -228,7 +201,6 @@ getSheetShowR tid csh shn = do
$(widgetFile "sheetShow")
[whamlet| Under Construction !!! |] -- TODO
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
getSheetFileR tid csh shn typ title = do
content <- runDB $ E.select $ E.from $

60
src/Handler/Submission.hs
View File

@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.State.Class
import Control.Monad.Trans.State.Strict (StateT)
import qualified Data.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.CaseInsensitive as CI
@ -42,6 +43,55 @@ import Colonnade
import Yesod.Colonnade
import qualified Text.Blaze.Html5.Attributes as HA
makeSubmissionForm :: Bool -> Form (Source Handler File)
makeSubmissionForm unpackZips = identForm FIDsubmission $ \html -> do
flip (renderAForm FormStandard) html $
areq (zipFileField unpackZips) "Zip Archiv zur Abgabe" Nothing
<* submitButton
getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
getSubmissionR = postSubmissionR
postSubmissionR tid csh shn (SubmissionMode mcid) = do
uid <- requireAuthId
msmid <- traverse decrypt mcid
shid <- runDB $ do
shid <- fetchSheetId tid csh shn
case msmid of
Nothing -> return shid
(Just smid) -> do
shid' <- submissionSheetId <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
return shid
let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips
case res of
(FormSuccess files) -> do
smid <- runDB $ runConduit $
transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
cID <- encrypt smid
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_other -> return ()
let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
let formTitle = pageTitle
let formText = Nothing :: Maybe UniWorXMessage
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
defaultLayout $ do
setTitleI pageTitle
$(widgetFile "formPageI18n")
------------------------- DEMO BELOW
submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
submissionTable = do
subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
@ -56,7 +106,7 @@ submissionTable = do
let
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
anchorSubmission (_, cUUID, _) = SubmissionR cUUID
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
colonnade = mconcat
[ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
@ -211,9 +261,11 @@ getSubmissionDownloadArchiveR path = do
info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
getSubmissionR = postSubmissionR
postSubmissionR cID = do
getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
getSubmissionDemoR = postSubmissionDemoR
postSubmissionDemoR cID = do
submissionId <- decrypt cID
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)

7
src/Handler/Utils.hs
View File

@ -16,7 +16,8 @@ import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils
import Handler.Utils.Table.Pagination as Handler.Utils
import Handler.Utils.Zip as Handler.Utils
import Handler.Utils.Rating as Handler.Utils
import Handler.Utils.Zip as Handler.Utils
import Handler.Utils.Rating as Handler.Utils
import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Templates as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates as Handler.Utils

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

@ -44,7 +44,7 @@ import qualified Data.Set as Set
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------
data FormIdentifier = FIDcourse | FIDsheet
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission
deriving (Enum, Eq, Ord, Bounded, Read, Show)

3
src/Model/Types.hs
View File

@ -158,3 +158,6 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType"

2
templates/submission.hamlet
View File

@ -33,7 +33,7 @@
<div .panel .panel-default>
<div .panel-heading>
Abgabe ersetzen
<form role=form method=post action=@{SubmissionR cID} enctype=#{uploadEnctype} .panel-body>
<form role=form method=post action=@{SubmissionDemoR cID} enctype=#{uploadEnctype} .panel-body>
^{uploadWidget}
<div .panel .panel-default>