Propagate restriction on 'rated' to file downloads

src/Handler/Corrections.hs

@@ -207,7 +207,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
     FormMissing      -> return ()
     FormSuccess (CorrDownloadData, subs) -> do
       ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
-      addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
+      addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
       sendResponse =<< submissionMultiArchive ids
     FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
       subs <- mapM decrypt $ Set.toList subs'

src/Handler/Sheet.hs

@@ -274,7 +274,7 @@ getSShowR tid csh shn = do
 
 getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
 getSFileR tid csh shn typ title = do
-  content <- runDB $ E.select $ E.from $
+  results <- runDB $ E.select $ E.from $
     \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
       -- Restrict to consistent rows that correspond to each other
       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
@@ -288,15 +288,18 @@ getSFileR tid csh shn typ title = do
         E.&&.   (course    E.^. CourseTerm    E.==. E.val tid  )
         )
       -- return desired columns
-      return $ file E.^. FileContent
+      return $ (file E.^. FileTitle, file E.^. FileContent)
   let mimeType = defaultMimeLookup $ pack title
-  case content of
-    [E.Value (Just nochmalContent)] -> do
-      addHeader "Content-Disposition" "attachment"
-      respond mimeType nochmalContent
-    []     -> notFound
-    _other -> error "Multiple matching files found."
-
+  case results of
+    [(E.Value fileTitle, E.Value fileContent)]
+      | Just fileContent' <- fileContent -> do
+          addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+      | otherwise -> sendResponseStatus noContent204 ()
+    [] -> notFound
+    other -> do
+      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
+      error "Multiple matching files found."
 
 getSheetNewR :: TermId -> Text -> Handler Html
 getSheetNewR tid csh = do

src/Handler/Submission.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -56,8 +56,6 @@ import Colonnade hiding (bool, fromMaybe)
 import qualified Yesod.Colonnade as Yesod
 import qualified Text.Blaze.Html5.Attributes as HA
 
-import Text.Shakespeare.Text (st)
-
 
 numberOfSubmissionEditDates :: Int64
 numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
@@ -143,7 +141,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             addMessageI "info" $ MsgSubmissionAlreadyExists
             redirect $ CSubmissionR tid csh shn cID SubShowR
       (Just smid) -> do
-        submissionMatchesSheet tid csh shn (fromJust mcid)
+        void $ submissionMatchesSheet tid csh shn (fromJust mcid)
         
         shid' <- submissionSheet <$> get404 smid
         -- fetch buddies from current submission
@@ -311,40 +309,52 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
 
 getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
 getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
-  submissionID <- decrypt cID
-
   runDB $ do
-    submissionMatchesSheet tid csh shn cID
+    submissionID <- submissionMatchesSheet tid csh shn cID
 
     isRating <- maybe False (== submissionID) <$> isRatingFile path
+
+    when (isUpdate || isRating) $
+      guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False
+  
     case isRating of
-      True  -> do
-        file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
-        maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+      True
+        | isUpdate -> do
+            file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
+            maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+        | otherwise -> notFound
       False -> do
         results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
           E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
           E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
                E.&&. f E.^. FileTitle E.==. E.val path
-               E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
                E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
                E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+               -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
           return f
 
         let fileName = Text.pack $ takeFileName path
         case results of
-          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
-          _ -> notFound
+          [Entity _ File{ fileContent = Just c, fileTitle }] -> do
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+            return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
+          [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
+          other -> do
+            $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
+            error "Multiple matching files found."
 
 getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
 getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
-  submissionID <- decrypt cID
-
-  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}-#{toPathPiece sfType}.zip"|]
+  when (sfType == SubmissionCorrected) $ 
+    guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
 
+  let filename
+        | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
+        | otherwise = ZIPArchiveName $ toPathPiece cID
+  
+  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
   respondSourceDB "application/zip" $ do
-    lift $ submissionMatchesSheet tid csh shn cID
-
+    submissionID <- lift $ submissionMatchesSheet tid csh shn cID
     rating <- lift $ getRating submissionID
 
     let
@@ -361,6 +371,6 @@ getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
         when (sfType == SubmissionCorrected) $
           maybe (return ()) (yieldM . ratingFile cID) rating
 
-      zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext
+      zipComment = Text.encodeUtf8 $ toPathPiece cID
 
     fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder

src/Handler/Utils/Submission.hs

@@ -462,11 +462,7 @@ sinkMultiSubmission userId isUpdate = do
             Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
-            authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
-            case authRes of
-              AuthenticationRequired -> notAuthenticated
-              Unauthorized t -> permissionDenied t
-              Authorized -> return ()
+            guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
           return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
       sink' <- lift $ yield val ++$$ sink
       case sink' of
@@ -512,9 +508,10 @@ sinkMultiSubmission userId isUpdate = do
     handleCryptoID _ = return Nothing
     
 
-submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
+submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB SubmissionId
 submissionMatchesSheet tid csh shn cid = do
   sid <- decrypt cid
   shid <- fetchSheetId tid csh shn
   Submission{..} <- get404 sid
   when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
+  return sid

src/Import/NoFoundation.hs

@@ -19,3 +19,5 @@ import CryptoID               as Import
 import Data.UUID              as Import (UUID)
 
 import Text.Lucius            as Import
+
+import Text.Shakespeare.Text  as Import hiding (text, stext)

src/Utils.hs

@@ -51,6 +51,11 @@ instance Monad FormResult where
   (FormFailure errs) >>= _ = FormFailure errs
   (FormSuccess a)    >>= f = f a
 
+guardAuthResult :: MonadHandler m => AuthResult -> m ()
+guardAuthResult AuthenticationRequired = notAuthenticated
+guardAuthResult (Unauthorized t) = permissionDenied t
+guardAuthResult Authorized = return ()
+
 
 
 ---------------------