259 lines
11 KiB
Haskell
259 lines
11 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Handler.Submission where
|
|
|
|
import Import hiding (joinPath)
|
|
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import Handler.Utils
|
|
|
|
import Network.Mime
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.State.Class
|
|
import Control.Monad.Trans.State.Strict (StateT)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
import Data.Conduit.ResumableSink
|
|
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
import System.FilePath
|
|
|
|
import Colonnade
|
|
import Yesod.Colonnade
|
|
import qualified Text.Blaze.Html5.Attributes as HA
|
|
|
|
submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
|
|
submissionTable = do
|
|
subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
|
|
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId
|
|
|
|
return (sub, sheet, course)
|
|
|
|
cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
|
|
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
|
|
|
let
|
|
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
|
|
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
|
anchorSubmission (_, cUUID, _) = SubmissionR cUUID
|
|
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
|
colonnade = mconcat
|
|
[ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
|
|
, headed "Kurs" $ anchorCell anchorCourse courseText
|
|
, headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
|
|
]
|
|
toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
|
|
toExternal (_, cID, _) = return cID
|
|
fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
|
|
fromExternal = decrypt
|
|
headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
|
|
|
|
|
|
getSubmissionListR, postSubmissionListR :: Handler Html
|
|
getSubmissionListR = postSubmissionListR
|
|
postSubmissionListR = do
|
|
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
|
<$> areq checkBoxField "Dies sind Korrekturen" (Just False)
|
|
<*> fileAFormReq "Archiv"
|
|
<* submitButton
|
|
|
|
runDB $ do
|
|
case uploadResult of
|
|
FormMissing -> return ()
|
|
FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren."
|
|
FormSuccess (isUpdate, fInfo) -> do
|
|
userId <- lift requireAuthId
|
|
let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) ()
|
|
feed sId val = do
|
|
mSink <- gets $ Map.lookup sId
|
|
sink <- case mSink of
|
|
Just sink -> return sink
|
|
Nothing -> do
|
|
Submission{..} <- lift $ get404 sId
|
|
return . newResumableSink $ sinkSubmission submissionSheetId userId (Just (sId, isUpdate))
|
|
sink' <- lift $ yield val ++$$ sink
|
|
case sink' of
|
|
Left _ -> error "sinkSubmission returned prematurely"
|
|
Right nSink -> modify $ Map.insert sId nSink
|
|
sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) ()
|
|
sinkSubmissions = do
|
|
sinks <- execStateC Map.empty . awaitForever $ \case
|
|
v@(Right (sId, _)) -> lift $ feed sId v
|
|
(Left f@File{..}) -> case splitDirectories fileTitle of
|
|
(cID:rest)
|
|
| not (null rest) -> do
|
|
sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
|
|
lift . feed sId $ Left f{ fileTitle = joinPath rest }
|
|
| otherwise -> return ()
|
|
[] -> invalidArgs ["Encountered file/directory with empty name"]
|
|
lift $ mapM_ (void . closeResumableSink) sinks
|
|
|
|
runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions
|
|
|
|
(subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
|
|
|
|
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
|
|
|
|
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
|
submissionFileSource submissionID = 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)
|
|
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID
|
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
|
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
|
return f
|
|
|
|
postSubmissionDownloadMultiArchiveR :: Handler TypedContent
|
|
postSubmissionDownloadMultiArchiveR = do
|
|
((selectResult, _), _) <- runFormPost . withFragment $ submissionTable
|
|
|
|
case selectResult of
|
|
FormMissing -> invalidArgs ["Missing submission numbers"]
|
|
FormFailure errs -> invalidArgs errs
|
|
FormSuccess ids -> do
|
|
(dbrunner, cleanup) <- getDBRunner
|
|
|
|
ratedSubmissions <- runDBRunner dbrunner $ do
|
|
submissions <- selectList [ SubmissionId <-. ids ] []
|
|
forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
|
|
|
|
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
|
|
let
|
|
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
|
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
|
cID <- encrypt submissionID
|
|
|
|
let
|
|
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
|
|
|
fileEntitySource = do
|
|
submissionFileSource submissionID =$= Conduit.map entityVal
|
|
yieldM (ratingFile cID rating)
|
|
|
|
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
|
|
|
yield $ File
|
|
{ fileModified = submissionChanged
|
|
, fileTitle = directoryName
|
|
, fileContent = Nothing
|
|
}
|
|
|
|
fileEntitySource =$= mapC withinDirectory
|
|
|
|
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
|
|
|
|
getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
|
|
getSubmissionR = postSubmissionR
|
|
postSubmissionR cID = do
|
|
submissionId <- decrypt cID
|
|
|
|
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
|
<$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
|
|
<*> fileAFormReq "Datei"
|
|
<* submitButton
|
|
|
|
(submission, files) <- runDB $ do
|
|
submission <- do
|
|
submission@Submission{..} <- get404 submissionId
|
|
case uploadResult of
|
|
FormMissing -> return submission
|
|
FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren."
|
|
FormSuccess (isUpdate, fInfo) -> do
|
|
userId <- lift requireAuthId
|
|
let mimeType = defaultMimeLookup (fileName fInfo)
|
|
source
|
|
| mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
|
|
| otherwise = do
|
|
let fileTitle = Text.unpack $ fileName fInfo
|
|
fileModified <- liftIO getCurrentTime
|
|
yieldM $ do
|
|
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
|
|
return File{..}
|
|
submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate))
|
|
get404 submissionId'
|
|
|
|
files <- 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.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
|
return (f, sf)
|
|
return (submission, files)
|
|
|
|
let
|
|
Rating'{..} = Rating'
|
|
{ ratingPoints = submissionRatingPoints submission
|
|
, ratingComment = submissionRatingComment submission
|
|
, ratingTime = submissionRatingTime submission
|
|
}
|
|
|
|
cID' <- encrypt submissionId
|
|
let
|
|
archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
|
|
archiveName = archiveBaseName <.> "zip"
|
|
|
|
defaultLayout $(widgetFile "submission")
|