diff --git a/models b/models
index 3826d0fe4..469994b4f 100644
--- a/models
+++ b/models
@@ -104,6 +104,8 @@ SubmissionFile
fileId FileId
isUpdate Bool
UniqueSubmissionFile fileId submissionId isUpdate
+ UniqueFile fileId
+ deriving Show
SubmissionUser
userId UserId
submissionId SubmissionId
diff --git a/package.yaml b/package.yaml
index bb170951a..0f6d255de 100644
--- a/package.yaml
+++ b/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.
diff --git a/routes b/routes
index 9a7d0ac32..d10b4dd13 100644
--- a/routes
+++ b/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
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index 5e87a84d5..fbe19a830 100644
--- a/src/CryptoID.hs
+++ b/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
diff --git a/src/CryptoID/Base32.hs b/src/CryptoID/Base32.hs
new file mode 100644
index 000000000..732d40e5a
--- /dev/null
+++ b/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 . (<> "===")
diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs
index 81c8a984d..149484ca1 100644
--- a/src/CryptoID/TH.hs
+++ b/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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 733089953..0030296a2 100644
--- a/src/Foundation.hs
+++ b/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
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index a805c4ccd..52d9633b8 100644
--- a/src/Handler/Submission.hs
+++ b/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
- [whamlet|#{tshow submission}|]
+ let
+ 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")
diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs
index db1641d94..1cd1bd9fb 100644
--- a/src/Handler/Utils/Zip/Rating.hs
+++ b/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
diff --git a/templates/submission-list.hamlet b/templates/submission-list.hamlet
index eb64b5146..4f218c836 100644
--- a/templates/submission-list.hamlet
+++ b/templates/submission-list.hamlet
@@ -1,4 +1,4 @@