From 917d767d30a79a9d7d424053395343b0b28f12d8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Apr 2018 13:31:47 +0200 Subject: [PATCH] Cleanup SubmissionDownloadArchive --- routes | 7 ++-- src/CryptoID.hs | 13 ++++++ src/Foundation.hs | 2 +- src/Handler/Submission.hs | 82 ++++++++++++++++++------------------- templates/submission.hamlet | 2 +- 5 files changed, 57 insertions(+), 49 deletions(-) diff --git a/routes b/routes index 9552688ea..f311fb480 100644 --- a/routes +++ b/routes @@ -29,16 +29,15 @@ !/#Text/submission/#SubmissionMode SubmissionR GET POST !time +!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET +!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET +!/#UUID CryptoUUIDDispatchR GET -- TODO below /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionDemoR GET POST /submissions.zip SubmissionDownloadMultiArchiveR POST -!/submission/archive/#FilePath SubmissionDownloadArchiveR GET -!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET - -!/#UUID CryptoUUIDDispatchR GET -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditIDR GET diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 7c04d7b3f..c66005307 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module CryptoID @@ -25,6 +26,9 @@ import System.FilePath.Cryptographic.ImplicitNamespace import Data.UUID.Types import Web.PathPieces +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + instance PathPiece UUID where fromPathPiece = fromString . unpack @@ -51,3 +55,12 @@ 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) + +instance PathPiece (ZIPArchiveName objID) where + fromPathPiece (map CI.mk . unpack -> s) + | Just s' <- stripSuffix (map CI.mk ".zip") s = Just . ZIPArchiveName . CryptoID . CI.mk $ map CI.original s' + | otherwise = Nothing + + toPathPiece (ZIPArchiveName CryptoID{..}) = pack (CI.foldedCase ciphertext) <> ".zip" diff --git a/src/Foundation.hs b/src/Foundation.hs index d02a5e08c..8f547d1db 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -251,7 +251,7 @@ isAuthorizedDB route@(routeAttrs -> attrs) writeable isAuthorizedDB UsersR _ = adminAccess Nothing 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 (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionAccess $ Left cID isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseNewR _ = lecturerAccess Nothing diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 9550a6791..f101588f8 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -190,7 +190,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID Nothing -> return () - mArCid <- fmap (CI.original . ciphertext) <$> traverse encrypt msmid + mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid let mCidArCid = (,) <$> mcid <*> mArCid let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn @@ -227,7 +227,45 @@ submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f +getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> 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) + 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 + E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) + E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID) + E.where_ (f E.^. FileTitle E.==. E.val path) + E.where_ . E.not_ . E.isNothing $ f E.^. FileContent + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] + return f + + let fileName = Text.pack $ takeFileName path + case results of + [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) + _ -> notFound + +getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent +getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do + submissionID <- decrypt cID + cUUID <- encrypt submissionID + respondSourceDB "application/zip" $ do + rating <- lift $ getRating submissionID + case rating of + Nothing -> lift notFound + Just rating' -> do + let fileEntitySource' :: Source (YesodDB UniWorX) File + fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') + info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } + fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder @@ -312,31 +350,6 @@ postSubmissionListR = do defaultLayout $(widgetFile "submission-list") -getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> 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) - 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 - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) - E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID) - E.where_ (f E.^. FileTitle E.==. E.val path) - E.where_ . E.not_ . E.isNothing $ f E.^. FileContent - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return f - - let fileName = Text.pack $ takeFileName path - case results of - [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) - _ -> notFound postSubmissionDownloadMultiArchiveR :: Handler TypedContent @@ -383,23 +396,6 @@ postSubmissionDownloadMultiArchiveR = do mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder -getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent -getSubmissionDownloadArchiveR path = do - let (baseName, ext) = splitExtension path - cID :: CryptoFileNameSubmission - cID = CryptoID $ CI.mk baseName - unless (ext == ".zip") notFound - submissionID <- decrypt cID - cUUID <- encrypt submissionID - respondSourceDB "application/zip" $ do - rating <- lift $ getRating submissionID - case rating of - Nothing -> lift notFound - Just rating' -> do - let fileEntitySource' :: Source (YesodDB UniWorX) File - fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') - info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } - fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d8ea8ae89..469e076bb 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -27,7 +27,7 @@
Abgabe herunterladen
- + $#