Download of submission files (single & as archive)

models

@@ -104,6 +104,8 @@ SubmissionFile
     fileId          FileId 
     isUpdate        Bool
     UniqueSubmissionFile fileId submissionId isUpdate
+    UniqueFile fileId
+    deriving Show
 SubmissionUser
     userId          UserId
     submissionId    SubmissionId

package.yaml

@@ -66,6 +66,8 @@ dependencies:
 - binary
 - mtl
 - sandi
+- esqueleto
+- mime-types
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -20,6 +20,8 @@
 
 /submission                 SubmissionListR GET
 /submission/#CryptoUUIDSubmission SubmissionR GET POST
+!/submission/archive/#FilePath SubmissionDownloadArchiveR GET
+!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
 
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/CryptoID.hs

@@ -8,6 +8,7 @@ module CryptoID
   ( module CryptoID
   , module Data.UUID.Cryptographic
   , module Data.CryptoID.Poly
+  , module CryptoID.Base32
   ) where
 
 import CryptoID.TH
@@ -16,7 +17,8 @@ import ClassyPrelude hiding (fromString)
 import Model
 
 import Data.CryptoID
-import Data.CryptoID.Poly hiding (decrypt, encrypt)
+import Data.CryptoID.Poly hiding (encrypt, decrypt)
+import CryptoID.Base32 hiding (encrypt, decrypt)
 
 import Data.UUID.Cryptographic
 import Data.UUID.Types

src/CryptoID/Base32.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module CryptoID.Base32
+  ( encrypt
+  , decrypt
+  , Base32
+  ) where
+
+import ClassyPrelude
+
+import qualified Codec.Binary.Base32 as Base32
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+
+import qualified Data.CryptoID.Poly as Poly (encrypt, decrypt)
+import Data.CryptoID.Poly hiding (encrypt, decrypt)
+
+import GHC.TypeLits
+import Data.Binary (Binary)
+
+
+type Base32 = CI Text
+type CryptoFileName namespace = CryptoID namespace Base32
+
+
+encrypt :: ( KnownSymbol namespace
+           , MonadThrow m
+           , Binary a
+           ) => CryptoIDKey -> a -> m (CryptoFileName namespace)
+encrypt = Poly.encrypt Nothing base32
+  where
+    base32 = return . CI.mk . Text.dropWhileEnd (== '=') . Text.decodeUtf8 . Base32.encode
+  
+decrypt :: ( KnownSymbol namespace
+           , MonadThrow m
+           , Binary a
+           ) => CryptoIDKey -> CryptoFileName namespace -> m a
+decrypt = Poly.decrypt unbase32
+  where
+    unbase32 = (\bs -> either (const . throwM $ CiphertextConversionFailed bs) return $ Base32.decode bs) . Text.encodeUtf8 . Text.toUpper . CI.original . (<> "===")

src/CryptoID/TH.hs

@@ -11,6 +11,7 @@ import Language.Haskell.TH
 import Data.CryptoID (CryptoID)
 import Data.UUID.Types (UUID)
 import Data.Binary (Binary(..))
+import CryptoID.Base32 (Base32)
 
 import Database.Persist.Sql (toSqlKey, fromSqlKey)
 
@@ -22,10 +23,12 @@ decTypeAliases = return . concatMap decTypeAliases'
     decTypeAliases' n
       = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
         , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
+        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` ConT ''Base32
         ]
       where
         cryptoIDn = mkName $ "CryptoID" ++ n
         cryptoUUIDn = mkName $ "CryptoUUID" ++ n
+        cryptoBase32n = mkName $ "CryptoFileName" ++ n
 
 decKeysBinary :: [Name] -> DecsQ
 decKeysBinary = fmap concat . mapM decKeyBinary

src/Foundation.hs

@@ -175,6 +175,8 @@ instance Yesod UniWorX where
     isAuthorized (CourseListTermR _)  _ = return Authorized
     isAuthorized SubmissionListR      _ = return Authorized
     isAuthorized (SubmissionR _)      _ = return Authorized
+    isAuthorized (SubmissionDownloadSingleR _ _) _ = return Authorized
+    isAuthorized (SubmissionDownloadArchiveR _) _ = return Authorized
     -- TODO: change to Assistants    
     isAuthorized TermEditR              _ = return Authorized
     isAuthorized (TermEditExistR _)     _ = return Authorized    

src/Handler/Submission.hs

@@ -14,7 +14,20 @@ import Import
 
 import Handler.Utils
 
+import Network.Mime
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.CaseInsensitive as CI
+
 import qualified Data.UUID.Cryptographic as UUID
+import qualified CryptoID.Base32 as Base32
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.Conduit.List as Conduit
+
+import System.FilePath
 
 
 getSubmissionListR :: Handler Html
@@ -27,13 +40,62 @@ getSubmissionListR = do
   submissionList <- mapM cryptEntity entityList
   defaultLayout $(widgetFile "submission-list")
 
+getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
+getSubmissionDownloadSingleR cID path = do
+  cIDKey <- getsYesod appCryptoIDKey
+  submissionID <- UUID.decrypt cIDKey cID
+
+  results <- runDB . E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOn [E.don $ 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
+    return f
+
+  let fileName = Text.pack $ takeFileName path
+  case results of
+    [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
+    _ -> notFound
+
+getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
+getSubmissionDownloadArchiveR path = do
+  let (baseName, ext) = splitExtension path
+      cID :: CryptoFileNameSubmission
+      cID = CryptoID . CI.mk $ Text.pack baseName
+  unless (ext == ".zip") notFound
+  cIDKey <- getsYesod appCryptoIDKey
+  submissionID <- Base32.decrypt cIDKey cID
+  cUUID <- UUID.encrypt cIDKey submissionID
+  runDB $ do
+    exists <- count [SubmissionId ==. submissionID]
+    unless (exists == 1) notFound
+    sqlBackend <- ask
+    let fileEntitySource = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+          return f
+        fileEntitySource' :: Source (ResourceT IO) File
+        fileEntitySource' = runReaderC sqlBackend fileEntitySource =$= Conduit.map entityVal
+        info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
+    return . TypedContent "application/zip" . toContent $ fileEntitySource' =$= produceZip info
 
 getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
 getSubmissionR = postSubmissionR
 postSubmissionR cID = do
   cIDKey <- getsYesod appCryptoIDKey
   submissionID <- UUID.decrypt cIDKey cID
-  submission <- runDB $ get404 (submissionID :: Key Submission)
+  (submission, files) <- runDB $ do
+    submission <- get404 (submissionID :: Key Submission)
+    files <- E.select . E.distinct . E.from $ \(sf `E.InnerJoin` f) -> do
+      E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+      return (f, sf)
+    return $ (submission, files)
 
-  defaultLayout $ do
+  let
-    [whamlet|<pre>#{tshow submission}|]
+    rating = (,) <$> submissionRatingPoints submission <*> submissionRatingComment submission
+
+  cID' <- Base32.encrypt cIDKey submissionID
+  let
+    archiveBaseName = Text.unpack . CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
+    archiveName = archiveBaseName <.> "zip"
+
+  defaultLayout $(widgetFile "submission")

src/Handler/Utils/Zip/Rating.hs

@@ -23,7 +23,6 @@ module Handler.Utils.Zip.Rating
 
 import Import hiding ((</>))
 
-import qualified Codec.Binary.Base32 as Base32
 
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
@@ -36,6 +35,7 @@ import Data.Text.Encoding.Error (UnicodeException(..))
   
 import qualified Data.Text.Lazy.Encoding as Lazy.Text
 
+import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
@@ -45,7 +45,7 @@ import Text.Read (readEither)
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
-import qualified Data.CryptoID.Poly as Poly
+import CryptoID.Base32 as Base32
 
 import System.FilePath
 
@@ -53,11 +53,14 @@ import System.FilePath
 instance HasResolution prec => Pretty (Fixed prec) where
   pretty = pretty . show
 
+instance Pretty x => Pretty (CI x) where
+  pretty = pretty . CI.original
+
 
 data Rating = Rating
   { ratingCourseName :: Text
   , ratingSheetName :: Text
-  , ratingSubmissionId :: CryptoIDSubmission String -- ^ 'SubmissionId'
+  , ratingSubmissionId :: CryptoFileNameSubmission
   , ratingComment :: Maybe Text
   , ratingPoints :: Maybe Points
   } deriving (Read, Show, Eq, Generic, Typeable)
@@ -81,10 +84,8 @@ getRating submissionId = runMaybeT $ do
   Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
   Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
   cIDKey <- getsYesod appCryptoIDKey
-  ratingSubmissionId <- Poly.encrypt Nothing base32 cIDKey submissionId
+  ratingSubmissionId <- Base32.encrypt cIDKey submissionId
   return Rating{..}
-  where
-    base32 = return . CI.foldCase . Text.unpack . Text.dropWhileEnd (== '=') . Text.decodeUtf8 . Base32.encode
 
 formatRating :: Rating -> Lazy.ByteString
 formatRating Rating{..} = let
@@ -153,20 +154,19 @@ isRatingFile :: ( MonadHandler m
 isRatingFile fName
   | Just cID <- isRatingFile' fName = do
       cIDKey <- getsYesod appCryptoIDKey
-      (Just <$> Poly.decrypt unbase32 cIDKey cID) `catch` decryptErrors
+      (Just <$> Base32.decrypt cIDKey cID) `catch` decryptErrors
   | otherwise = return Nothing
   where
-    unbase32 = (\bs -> either (const . throwM $ CiphertextConversionFailed bs) return $ Base32.decode bs) . Text.encodeUtf8 . Text.pack . toUpper . (<> "===")
 
     decryptErrors (CiphertextConversionFailed _) = return Nothing
     decryptErrors InvalidNamespaceDetected       = return Nothing
     decryptErrors DeserializationError           = return Nothing
     decryptErrors err                            = throwM err
 
-isRatingFile' :: FilePath -> Maybe (CryptoIDSubmission String)
+isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
 isRatingFile' (takeFileName -> fName)
   | (bName, ".txt") <- splitExtension fName
-  , Just ciphertext <- stripPrefix "bewertung_" bName
+  , Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
   = Just CryptoID{..}
   | otherwise
   = Nothing

templates/submission-list.hamlet

@@ -1,4 +1,4 @@
 <ul>
-  $forall (cID, val) <- submissionList
+  $forall (cID, _) <- submissionList
     <li>
       <a href=@{SubmissionR cID}>#{tshow $ ciphertext cID}

templates/submission.hamlet

@@ -0,0 +1,34 @@
+<pre style="display:none">
+  #{tshow submission}
+
+<table .table .table-striped>
+  $maybe (points, text) <- rating
+    <tr>
+      <td>Punkte
+      <td>#{tshow points}
+    <tr>
+      <td>Kommentar
+      <td>#{text}
+  $nothing
+    <tr>
+      <td colspan="2">Noch nicht bewertet
+  
+<a href=@{SubmissionDownloadArchiveR archiveName} download>Submission archive
+  
+<ul>
+  $forall (Entity _ file, Entity _ sFile) <- files
+    <li>
+      <pre style="display:none">
+        #{tshow file}
+      <pre style="display:none">
+        #{tshow sFile}
+
+      <b>#{fileTitle file}
+      $if submissionFileIsUpdate sFile
+         (Korrektur)
+      <br>
+      $maybe content <- fileContent file
+        <pre>
+          #{decodeUtf8 content}
+      $nothing
+        This is a directory