116 lines
4.3 KiB
Haskell
116 lines
4.3 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Handler.Submission where
|
|
|
|
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
|
|
getSubmissionListR = do
|
|
entityList <- runDB $ selectList [] []
|
|
cIDKey <- getsYesod appCryptoIDKey
|
|
let
|
|
cryptEntity :: Entity Submission -> Handler (CryptoUUIDSubmission, Submission)
|
|
cryptEntity (Entity key val) = (, val) <$> UUID.encrypt cIDKey key
|
|
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
|
|
cID' <- Base32.encrypt cIDKey submissionID
|
|
|
|
runDB $ do
|
|
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
|
case isRating of
|
|
True -> do
|
|
file <- (ratingFile cID' =<<) <$> getRating submissionID
|
|
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
|
False -> do
|
|
results <- 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
|
|
rating <- getRating submissionID
|
|
case rating of
|
|
Nothing -> notFound
|
|
Just rating' -> do
|
|
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 >> maybe (return ()) yield (ratingFile cID rating')
|
|
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, 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)
|
|
|
|
let
|
|
rating@(Rating'{..}) = Rating'
|
|
{ ratingPoints = submissionRatingPoints submission
|
|
, ratingComment = submissionRatingComment submission
|
|
, ratingTime = submissionRatingTime submission
|
|
}
|
|
|
|
cID' <- Base32.encrypt cIDKey submissionID
|
|
let
|
|
archiveBaseName = Text.unpack . CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
|
|
archiveName = archiveBaseName <.> "zip"
|
|
|
|
defaultLayout $(widgetFile "submission")
|