diff --git a/routes b/routes index 31885f668..0d7c3a1a0 100644 --- a/routes +++ b/routes @@ -99,6 +99,7 @@ /ex/unassigned SheetOldUnassignedR GET /ex/#SheetName SheetR: /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor + /show/download SArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1d08e0ba8..c14424251 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -425,7 +425,8 @@ getSShowR tid ssh csh shn = do defaultLayout $ do setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn - let visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet + let zipLink = CSheetR tid ssh csh shn SArchiveR + visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet @@ -433,6 +434,15 @@ getSShowR tid ssh csh shn = do markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) $(widgetFile "sheetShow") +getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSArchiveR tid ssh csh shn = do + MsgRenderer mr <- getMsgRenderer + let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <.> "zip" + sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes + allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound] + serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal + + getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSPseudonymR = postSPseudonymR postSPseudonymR tid ssh csh shn = do @@ -462,8 +472,10 @@ getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent -getSZipR tid ssh csh shn sft - = serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal +getSZipR tid ssh csh shn sft = do + MsgRenderer mr <- getMsgRenderer + let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <> "_" <> (unpack $ toPathPiece sft) <.> "zip" + serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 867291c47..ed7682772 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -93,6 +93,23 @@ serveSomeFiles archiveName source = do let zipComment = T.encodeUtf8 $ pack archiveName source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder +-- | Serve any number of files as a zip-archive of files, identified through a given DB query +-- +-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned +serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveZipArchive archiveName source = do + results <- runDB . runConduit $ source .| peekN 2 + + $logDebugS "serveZipArchive" . tshow $ length results + + case results of + [] -> notFound + _moreFiles -> do + setContentDisposition' $ Just archiveName + respondSourceDB "application/zip" $ do + let zipComment = T.encodeUtf8 $ pack archiveName + source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + --------- diff --git a/src/Utils.hs b/src/Utils.hs index b9239d9e3..e8f0d27f5 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -204,6 +204,10 @@ boolSymbol False = fontAwesomeIcon "times" -- tickmark :: IsString a => a -- tickmark = fromString "✔" +-- | remove all Whitespace from Text +stripAll :: Text -> Text +stripAll = Text.filter (not . isSpace) + -- | Convert text as it is to Html, may prevent ambiguous types -- This function definition is mainly for documentation purposes text2Html :: Text -> Html @@ -883,7 +887,7 @@ encodedSecretBoxOpen' :: (FromJSON a, MonadError EncodedSecretBoxException m) => SecretBox.Key -> Text -> m a encodedSecretBoxOpen' sKey chunked = do - let unchunked = Text.filter (not . isSpace) chunked + let unchunked = stripAll chunked decoded <- either (throwError . EncodedSecretBoxInvalidBase64) return . Base64.decode $ encodeUtf8 unchunked unless (BS.length decoded >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $ diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 0fa7da74f..192019102 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -74,11 +74,29 @@ sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file - E.where_ ((sFile E.^. SheetFileType E.==. E.val sft ) - E.&&. (sheet E.^. SheetName E.==. E.val shn ) + E.where_ ((sheet E.^. SheetName E.==. E.val shn ) E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.&&. (course E.^. CourseTerm E.==. E.val tid ) + E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) + ) + -- return file entity + return file + +-- | Return all files of certain `SheetFileTypes` for a `Sheet` +sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> Source (SqlPersistT m) (Entity File) +sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $ + \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do + -- Restrict to consistent rows that correspond to each other + E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) + E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) + E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) + -- filter to requested file + E.where_ ((sheet E.^. SheetName E.==. E.val shn ) + E.&&. (course E.^. CourseShorthand E.==. E.val csh ) + E.&&. (course E.^. CourseSchool E.==. E.val ssh ) + E.&&. (course E.^. CourseTerm E.==. E.val tid ) + E.&&. (sFile E.^. SheetFileType `E.in_` E.valList sfts ) ) -- return file entity return file diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 04ab1b8aa..198a831a6 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -52,5 +52,5 @@ $maybe marktxt <- markingText $if hasFiles
-

_{MsgSheetFiles} +

^{simpleLinkI (SomeMessage MsgSheetFiles) zipLink} ^{fileTable}