403 lines
18 KiB
Haskell
403 lines
18 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
|
|
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.Maybe
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
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.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
import System.FilePath
|
|
|
|
import Colonnade hiding (bool)
|
|
import Yesod.Colonnade
|
|
import qualified Text.Blaze.Html5.Attributes as HA
|
|
|
|
|
|
|
|
makeSubmissionForm :: Bool -> SheetGroup -> Form (Source Handler File, [Text])
|
|
makeSubmissionForm unpackZips grouping = identForm FIDsubmission $ \html -> do
|
|
flip (renderAForm FormStandard) html $ (,)
|
|
<$> areq (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
|
<*> (catMaybes <$> sequenceA [aopt textField (fsm $ MsgSubmissionMember g) Nothing | g <- [1..groupNr] ]) -- TODO: Convenience: preselect last buddies
|
|
<* submitButton
|
|
where
|
|
groupNr
|
|
| Arbitrary{..} <- grouping = pred maxParticipants -- pred to account for the person submitting
|
|
| otherwise = 0
|
|
|
|
getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
|
|
getSubmissionR = postSubmissionR
|
|
postSubmissionR tid csh shn (SubmissionMode mcid) = do
|
|
uid <- requireAuthId
|
|
msmid <- traverse decrypt mcid
|
|
(Entity shid Sheet{..}) <- runDB $ do
|
|
sheet@(Entity shid _) <- fetchSheet tid csh shn
|
|
case msmid of
|
|
Nothing -> do
|
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmissionId)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid
|
|
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
$logDebugS "Submission.DUPLICATENEW" (tshow submissions)
|
|
case submissions of
|
|
[] -> return shid
|
|
(E.Value smid:_) -> do
|
|
cID <- encrypt smid
|
|
addMessageI "info" $ MsgSubmissionAlreadyExists
|
|
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
|
return sheet
|
|
(Just smid) -> do
|
|
shid' <- submissionSheetId <$> get404 smid
|
|
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
|
|
return sheet
|
|
let unpackZips = True -- undefined -- TODO
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping
|
|
mCID <- runDB $ do
|
|
res' <- case res of
|
|
(FormMissing ) -> return $ FormMissing
|
|
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
|
(FormSuccess (files,[])) -> return $ FormSuccess (files,[]) -- Type change
|
|
(FormSuccess (files, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members
|
|
| (Arbitrary {..}) <- sheetGrouping
|
|
, length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
|
let gemails = map CI.foldedCase gEMails
|
|
prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
|
prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
|
participants <- fmap prep . E.select . E.from $ \user -> do
|
|
E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
|
|
let
|
|
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
|
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId
|
|
E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val sheetCourseId
|
|
return $ E.countRows E.>. E.val (0 :: Int64)
|
|
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId
|
|
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid
|
|
return $ E.countRows E.>. E.val (0 :: Int64)
|
|
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
|
|
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
|
|
mr <- getMessageRender
|
|
|
|
let failmsgs = flip Map.foldMapWithKey participants $ \email -> \case
|
|
Nothing -> [mr $ MsgEMailUnknown $ CI.original email]
|
|
(Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh]
|
|
(Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)]
|
|
_other -> mempty
|
|
return $ if null failmsgs
|
|
then FormSuccess (files, foldMap (\(Just (i,_,_)) -> [i]) participants)
|
|
else FormFailure failmsgs
|
|
|
|
| otherwise -> return $ FormFailure ["Mismatching number of group participants"]
|
|
|
|
|
|
case res' of
|
|
(FormSuccess (files,(setFromList -> adhocIds))) -> do
|
|
now <- liftIO $ getCurrentTime
|
|
smid <- do
|
|
smid <- runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
|
|
|
|
insertUnique $ SubmissionUser uid smid
|
|
-- insert $ SubmissionEdit uid now smid -- sinkSubmission already does this
|
|
|
|
-- Determine members of pre-registered group
|
|
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroupId
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid
|
|
E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId
|
|
return $ submissionGroupUser' E.^. SubmissionGroupUserUserId
|
|
|
|
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
|
forM_ (groupUids `Set.union` adhocIds) $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
|
|
|
|
return smid
|
|
cID <- encrypt smid
|
|
return $ Just cID
|
|
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
|
|
_other -> return Nothing
|
|
|
|
case mCID of
|
|
Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
|
|
Nothing -> return ()
|
|
|
|
let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
|
|
let formTitle = pageTitle
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-----------------------------------------------------------------------------------------------
|
|
------------------------- DEMO BELOW
|
|
|
|
|
|
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{..})) = CourseR courseTermId courseShorthand CourseShowR
|
|
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
|
anchorSubmission (_, cUUID, _) = SubmissionDemoR 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 }
|
|
|
|
lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
|
|
lastEditTime <- case lastEditMb of
|
|
[(submissionEditTime.entityVal -> time)] -> return time
|
|
_other -> liftIO getCurrentTime
|
|
yield $ File
|
|
{ fileModified = lastEditTime
|
|
, 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
|
|
|
|
|
|
|
|
getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
|
|
getSubmissionDemoR = postSubmissionDemoR
|
|
postSubmissionDemoR 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")
|