326 lines
16 KiB
Haskell
326 lines
16 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 #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
|
|
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 qualified Yesod.Colonnade as Yesod
|
|
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 (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) 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 -> CryptoFileNameSubmission -> 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) 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 uid (maybe (Left shid) Right msmid) False
|
|
_ -> 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 = MsgSubmissionEditHead 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 :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
|
colonnadeFiles cid = mconcat
|
|
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
|
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ 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=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv
|
|
$forall (name,time) <- lastEdits
|
|
<div>last edited by #{name} at #{formatTimeGerDTlong time}
|
|
$maybe fileTable <- mFileTable
|
|
<h3>Enthaltene Dateien:
|
|
^{fileTable}
|
|
|]
|
|
|
|
|
|
getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent
|
|
getSubmissionDownloadSingleR tid csh shn cID path = do
|
|
submissionID <- decrypt cID
|
|
|
|
runDB $ do
|
|
shid <- fetchSheetId tid csh shn
|
|
Submission{..} <- get404 submissionID
|
|
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
|
|
|
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 <> "; charset=utf-8") (toContent c)
|
|
_ -> notFound
|
|
|
|
getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent
|
|
getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
|
|
submissionID <- decrypt cID
|
|
cUUID <- encrypt submissionID
|
|
respondSourceDB "application/zip" $ do
|
|
lift $ do
|
|
shid <- fetchSheetId tid csh shn
|
|
Submission{..} <- get404 submissionID
|
|
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
|
|
|
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 . pack . CI.foldedCase $ ciphertext (cUUID :: CryptoFileNameSubmission) }
|
|
fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
|