Cleanup SubmissionDownloadArchive

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

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"

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

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
 
 
 

templates/submission.hamlet

@@ -27,7 +27,7 @@
         <div .panel-heading>
           Abgabe herunterladen
         <div .panel-body .text-center>
-          <a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
+          $#<a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
             <span .glyphicon .glyphicon-cloud-download aria-hidden="true"> ZIP-Archive
     <div .col-md-6>
       <div .panel .panel-default>