From 4c4cbd584cd39328ddcf5abe2a244ce6e35f222c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Apr 2018 15:09:20 +0200 Subject: [PATCH] Fix build of Submission.hs --- messages/de.msg | 2 +- src/Handler/Submission.hs | 79 +++++++++++++++++++++------------------ 2 files changed, 43 insertions(+), 38 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 76cdbc62d..9c8582fad 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -31,7 +31,7 @@ OnlyUploadOneFile: Bitte nur eine Datei hochladen. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe -SubmissionMember: Mitabgebende(r) +SubmissionMember g@Int: Mitabgebende(r) ###{tshow g} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 142a35bf7..304101890 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -28,6 +28,8 @@ 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 @@ -36,6 +38,7 @@ 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 @@ -51,7 +54,7 @@ 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 <$> replicateM groupNr (aopt textField (fsm MsgSubmissionMember) Nothing)) -- TODO: Convenience: preselect last buddies + <*> (catMaybes <$> sequenceA [aopt textField (fsm $ MsgSubmissionMember g) Nothing | g <- [1..groupNr] ]) -- TODO: Convenience: preselect last buddies <* submitButton where groupNr @@ -86,72 +89,74 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do return sheet let unpackZips = True -- undefined -- TODO ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping - runDB $ do + mCID <- runDB $ do res' <- case res of (FormMissing ) -> return $ FormMissing - (FormFailure failmsg) -> return $ FormFailure failmsgs + (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 - isParticipant <- E.sub_select . E.from $ \courseParticipant -> do - E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId - E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val cid - return $ E.countRows E.>. E.val 0 - 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 + 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 - if null failmsgs - then return $ FormSuccess (files, foldMap (\(Just (i,_,_)) -> [i]) participants) - else return $ FormFailure failmsgs + 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,gemails)) -> do + (FormSuccess (files,(setFromList -> adhocIds))) -> do now <- liftIO $ getCurrentTime - smid <- runDB $ do - -- AdHoc - - -- + smid <- do smid <- runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid) + insertUnique $ SubmissionUser uid smid - insert $ SubmissionEdit uid now smid - -- Gruppen Abgaben für Feste Gruppen - groupUids <- fmap setFromList . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do + -- 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 - forM_ (groupUids :: Set (E.Value UserId)) $ \(E.Value uid') -> void . insertUnique $ SubmissionUser uid' smid - -- Adhoc Gruppen - -- TODO - --TODO: SubmissionUser anlegen!!!! - --TODO: Permissions für GruppenAbgabe + -- 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 - redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID - (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml - _other -> return () + 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