From a544c61be2d2b13690bc54286bafe4a25b6222c3 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 10 Apr 2018 12:50:20 +0200 Subject: [PATCH] Submission upload (Sitzung mit Gregor) --- messages/de.msg | 4 ++- routes | 17 ++++++---- src/CryptoID.hs | 14 ++++++++ src/Foundation.hs | 14 ++++---- src/Handler/CryptoIDDispatch.hs | 12 +++++-- src/Handler/Sheet.hs | 30 +---------------- src/Handler/Submission.hs | 60 ++++++++++++++++++++++++++++++--- src/Handler/Utils.hs | 7 ++-- src/Handler/Utils/Form.hs | 2 +- src/Model/Types.hs | 3 ++ templates/submission.hamlet | 2 +- 11 files changed, 110 insertions(+), 55 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index fb15e4fea..44b84282e 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -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. \ No newline at end of file +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 diff --git a/routes b/routes index 075a60fd4..9552688ea 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index ed2864eab..7c04d7b3f 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -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 + diff --git a/src/Foundation.hs b/src/Foundation.hs index 1ca4de6fa..b4acfa24d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 0eff808f2..c604d3e45 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a7f672cc7..4f3b8bf9a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 $ diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3e2160d28..a321b4ddd 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 $ (,) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 33fc5f0f4..72a833f48 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 1936769ee..cfd104d15 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 9aac70705..da0073707 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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" + + + diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 5c678476a..d8ea8ae89 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -33,7 +33,7 @@
Abgabe ersetzen -
+ ^{uploadWidget}