514 lines
24 KiB
Haskell
514 lines
24 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE ParallelListComp #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
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 Data.Bifunctor
|
|
|
|
import System.FilePath
|
|
|
|
import Colonnade hiding (bool)
|
|
import Yesod.Colonnade
|
|
import qualified Text.Blaze.Html5.Attributes as HA
|
|
|
|
|
|
numberOfSubmissionEditDates :: Int64
|
|
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
|
|
|
|
|
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text])
|
|
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
|
flip (renderAForm FormStandard) html $ (,)
|
|
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
|
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) buddy
|
|
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
|
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
|
])
|
|
<* submitButton
|
|
where
|
|
(groupNr, editableBuddies)
|
|
| Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
|
|
| otherwise = (0, False)
|
|
|
|
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
|
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
|
|
|
getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html
|
|
getSubmissionNewR = postSubmissionNewR
|
|
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
|
|
|
|
|
|
getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html
|
|
getSubmissionR = postSubmissionR
|
|
postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
|
|
|
|
getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
|
|
getSubmissionOwnR tid csh shn = do
|
|
authId <- requireAuthId
|
|
sid <- runDB $ do
|
|
shid <- fetchSheetId tid csh shn
|
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
case submissions of
|
|
((E.Value sid):_) -> return sid
|
|
[] -> notFound
|
|
cID <- encrypt sid
|
|
redirect . CourseR tid csh . SheetR shn $ SubmissionR cID
|
|
|
|
submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
|
|
submissionHelper tid csh shn (SubmissionMode mcid) = do
|
|
uid <- requireAuthId
|
|
msmid <- traverse decrypt mcid
|
|
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
|
sheet@(Entity shid Sheet{..}) <- 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.^. SubmissionUserSubmission)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
|
|
return $ submission E.^. SubmissionId
|
|
-- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
|
|
case submissions of
|
|
[] -> do
|
|
-- fetch buddies from previous submission in this course
|
|
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
|
|
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
|
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
|
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
E.limit 1
|
|
return $ submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return $ user E.^. UserEmail
|
|
return (sheet,buddies,[])
|
|
(E.Value smid:_) -> do
|
|
cID <- encrypt smid
|
|
addMessageI "info" $ MsgSubmissionAlreadyExists
|
|
redirect $ CSheetR tid csh shn $ SubmissionR cID
|
|
(Just smid) -> do
|
|
shid' <- submissionSheet <$> get404 smid
|
|
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
|
|
-- fetch buddies from current submission
|
|
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
|
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
return $ user E.^. UserEmail
|
|
-- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime]
|
|
lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
|
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
|
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
|
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
E.limit numberOfSubmissionEditDates
|
|
return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
|
|
let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
|
|
return (sheet,buddies,lastEdits)
|
|
let unpackZips = True -- undefined -- TODO
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies
|
|
mCID <- runDB $ do
|
|
res' <- case res of
|
|
(FormMissing ) -> return $ FormMissing
|
|
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
|
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
|
|
(FormSuccess (mFiles, (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.^. CourseParticipantUser
|
|
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
|
|
return $ E.countRows E.>. E.val (0 :: Int64)
|
|
hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
|
E.&&. submission E.^. SubmissionSheet 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 (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
|
|
else FormFailure failmsgs
|
|
|
|
| otherwise -> return $ FormFailure ["Mismatching number of group participants"]
|
|
|
|
|
|
case res' of
|
|
(FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
|
|
now <- liftIO $ getCurrentTime
|
|
smid <- do
|
|
smid <- case (mFiles, msmid) of
|
|
(Nothing, Just smid) -- no new files, existing submission partners updated
|
|
-> return smid
|
|
(Just files, _) -- new files
|
|
-> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid)
|
|
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
|
-- 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.^. SubmissionGroupUserSubmissionGroup
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
|
|
-- SubmissionUser for all group members (pre-registered & ad-hoc)
|
|
let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
|
|
-- remove obsolete old entries
|
|
deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
|
|
-- maybe add current users
|
|
forM_ subUsers $ \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 $ CSheetR tid csh shn $ SubmissionR cID
|
|
Nothing -> return ()
|
|
|
|
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
|
|
|
|
let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
|
|
let formTitle = pageTitle
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
|
-- Maybe construct a table to display uploaded archive files
|
|
let colonnadeFiles cid = mconcat
|
|
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
|
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
|
|
(\(Entity _ File{..}) -> str2widget fileTitle)
|
|
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
|
]
|
|
smid2ArchiveTable (smid,cid) = DBTable
|
|
{ dbtSQLQuery = submissionFileQuery smid
|
|
, dbtColonnade = colonnadeFiles cid
|
|
, dbtAttrs = tableDefault
|
|
, dbtIdent = "files" :: Text
|
|
, dbtSorting = [ ( "path"
|
|
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle
|
|
)
|
|
, ( "time"
|
|
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
|
|
)
|
|
]
|
|
, dbtFilter = []
|
|
}
|
|
mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
|
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
[whamlet|
|
|
$maybe arCid <- mArCid
|
|
<hr>
|
|
<h2>
|
|
<a href=@{SubmissionDownloadArchiveR arCid}>Archiv
|
|
$forall (name,time) <- lastEdits
|
|
<div>last edited by #{name} at #{formatTimeGerDTlong time}
|
|
$maybe fileTable <- mFileTable
|
|
<h3>Enthaltene Dateien:
|
|
^{fileTable}
|
|
|]
|
|
|
|
|
|
|
|
|
|
|
|
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
|
submissionFileSource = E.selectSource . E.from . submissionFileQuery
|
|
|
|
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
|
-> E.SqlQuery (E.SqlExpr (Entity File))
|
|
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
|
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
|
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
|
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
|
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
|
return f
|
|
|
|
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.^. SubmissionFileFile)
|
|
E.where_ (sf E.^. SubmissionFileSubmission 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
|
|
|
|
getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent
|
|
getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-----------------------------------------------------------------------------------------------
|
|
------------------------- 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.^. SheetCourse
|
|
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
|
|
|
|
return (sub, sheet, course)
|
|
|
|
cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
|
|
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
|
|
|
let
|
|
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
|
|
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 submissionSheet 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")
|
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
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 submissionSheet 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.^. SubmissionFileFile)
|
|
E.where_ (sf E.^. SubmissionFileSubmission 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")
|