diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4fb54c59b..05b9b6579 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -210,6 +210,7 @@ SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt. SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen +NoOpenSubmissions: Keine unkorrigierten Abgaben vorhanden SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen? SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"} @@ -793,8 +794,9 @@ MenuSheetEdit: Übungsblatt editieren MenuSheetDelete: Übungsblatt löschen MenuSheetClone: Als neues Übungsblatt klonen MenuCorrectionsUpload: Korrekturen hochladen +MenuCorrectionsDownload: Abgaben herunterladen MenuCorrectionsCreate: Abgaben registrieren -MenuCorrectionsGrade: Abgaben bewerten +MenuCorrectionsGrade: Abgaben online korrigieren MenuAuthPreds: Authorisierungseinstellungen MenuTutorialDelete: Tutorium löschen MenuTutorialEdit: Tutorium editieren diff --git a/package.yaml b/package.yaml index 5dd414b33..d0fc06ae8 100644 --- a/package.yaml +++ b/package.yaml @@ -185,6 +185,7 @@ ghc-options: - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures - -fno-max-relevant-binds + - -j2 when: - condition: flag(pedantic) diff --git a/routes b/routes index 34a0bb4ff..45fa74da5 100644 --- a/routes +++ b/routes @@ -137,10 +137,11 @@ /tutor-invite TInviteR GET POST -/subs CorrectionsR GET POST !corrector !lecturer -/subs/upload CorrectionsUploadR GET POST !corrector !lecturer -/subs/create CorrectionsCreateR GET POST !corrector !lecturer -/subs/grade CorrectionsGradeR GET POST !corrector !lecturer +/subs CorrectionsR GET POST !corrector !lecturer +/subs/upload CorrectionsUploadR GET POST !corrector !lecturer +/subs/create CorrectionsCreateR GET POST !corrector !lecturer +/subs/grade CorrectionsGradeR GET POST !corrector !lecturer +/subs/download CorrectionsDownloadR GET !corrector !lecturer /msgs MessageListR GET POST diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 218c96d70..52cd68cdc 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -50,7 +50,8 @@ sqlInTuple arity = do ] -- | Generic unValuing of Tuples of Values, i.e. --- $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c) +-- +-- > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c) unValueN :: Int -> ExpQ unValueN arity = do vs <- replicateM arity $ newName "v" @@ -60,7 +61,8 @@ unValueN arity = do lam1E pat rhs -- | Generic unValuing of certain indices of a Tuple, i.e. --- $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c) +-- +-- > $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c) unValueNIs :: Int -> [Int] -> ExpQ unValueNIs arity uvIdx = do vs <- replicateM arity $ newName "v" @@ -74,8 +76,9 @@ unValueNIs arity uvIdx = do -- | Generic projections for InnerJoin-tuples --- gives I-th element of N-tuple of left-associative InnerJoin-pairs, --- i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) +-- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e. +-- +-- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) sqlIJproj :: Int -> Int -> ExpQ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin diff --git a/src/Foundation.hs b/src/Foundation.hs index 11c865ef9..733a55a9f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2231,6 +2231,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = ] pageActions (CorrectionsR) = [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsDownload + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute CorrectionsDownloadR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsUpload , menuItemIcon = Nothing diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 15646baea..d32195c58 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -502,7 +502,7 @@ postCorrectionsR = do let whereClause = ratedBy uid colonnade = mconcat [ colSelect - , dbRow + -- , dbRow , colSchool , colTerm , colCourse diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index bdad11b37..3e31fb658 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -600,3 +600,16 @@ postSubDelR tid ssh csh shn cID = do { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR } + + +getCorrectionsDownloadR :: Handler TypedContent +getCorrectionsDownloadR = do -- download all assigned and open submissions + uid <- requireAuthId + subs <- runDB $ selectKeysList + [ SubmissionRatingBy ==. Just uid + , SubmissionRatingTime ==. Nothing + ] [] + when (null subs) $ do + addMessageI Info MsgNoOpenSubmissions + redirect CorrectionsR + submissionMultiArchive $ Set.fromList subs \ No newline at end of file diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 33168da0e..ef297bff4 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -19,7 +19,7 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Utils.Lens import Control.Monad.State hiding (forM_, mapM_,foldM) -import Control.Monad.Writer (MonadWriter(..), execWriterT) +import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) import Control.Monad.RWS.Lazy (RWST) import qualified Control.Monad.Random as Rand import qualified System.Random.Shuffle as Rand (shuffleM) @@ -43,6 +43,7 @@ import qualified Handler.Utils.Rating as Rating (extractRatings) import Handler.Utils.Delete import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils.TH as E import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink @@ -223,17 +224,34 @@ submissionMultiArchive (Set.toList -> ids) = do (dbrunner, cleanup) <- getDBRunner ratedSubmissions <- runDBRunner dbrunner $ do - submissions <- selectList [ SubmissionId <-. ids ] [] - forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId + submissions <- E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids + return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm)) + + forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) -> + maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 4) courseSheetInfo)) =<< getRating submissionId + let (setSheet,setCourse,setSchool,setTerm) = + execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) -> + tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do let - fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File - fileEntitySource' (rating, Entity submissionID Submission{..}) = do + fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File + fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do cID <- encrypt submissionID let - directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission) + dirFrag :: PathPiece p => p -> FilePath + dirFrag = Text.unpack . toPathPiece + submissionDirectory = dirFrag (cID :: CryptoFileNameSubmission) + directoryName + | Set.size setTerm > 1 = dirFrag tid dirFrag ssh dirFrag csh dirFrag shn submissionDirectory + | Set.size setSchool > 1 = dirFrag ssh dirFrag csh dirFrag shn submissionDirectory + | Set.size setCourse > 1 = dirFrag csh dirFrag shn submissionDirectory + | Set.size setSheet > 1 = dirFrag shn submissionDirectory + | otherwise = submissionDirectory fileEntitySource = do submissionFileSource submissionID =$= Conduit.map entityVal diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 241947549..d2f0cf11e 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -3,7 +3,7 @@ module Utils.Sheet where import Import.NoFoundation import qualified Database.Esqueleto as E -import Database.Esqueleto.Internal.Language (From) -- How to avoid this import? +import Database.Esqueleto.Internal.Language (From) -- cannot be avoided here -- DB Queries for Sheets that are used in several places @@ -85,7 +85,6 @@ sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $ -- | Check whether a sheet has any files for a given file type hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SheetFile)) --- hasSheetFileQuery :: (E.Esqueleto query expr backend) => expr (Entity Sheet) -> SheetFileType -> expr (E.Value Bool) hasSheetFileQuery sheet sft = E.exists $ E.from $ \sFile -> diff --git a/templates/i18n/README_i18n.txt b/templates/i18n/README_i18n.txt new file mode 100644 index 000000000..9915cdd0b --- /dev/null +++ b/templates/i18n/README_i18n.txt @@ -0,0 +1,6 @@ +This directories contains all language dependent widgets. + +Each widget requires its own directories, the name of which is needed in the source code, e.g. for directory "imprint" + $(i18nWidgetFile "imprint") +inside this directory must be one file per language "de.hamlet", etc. +