From fcd6703752ca8829fe5e9b4d267206514f2db9ee Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 11 Apr 2018 13:12:49 +0200 Subject: [PATCH] Group Submissions mostly done, NOT COMPILING --- messages/de.msg | 13 ++++ models | 3 +- src/Handler/Sheet.hs | 2 +- src/Handler/Submission.hs | 118 +++++++++++++++++++++++++++++++------ src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/Sheet.hs | 3 + src/Model/Types.hs | 2 +- 7 files changed, 121 insertions(+), 22 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 44b84282e..76cdbc62d 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -5,11 +5,13 @@ Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num} TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert. TermNewTitle: Semester editiere/anlegen. InvalidInput: Eingaben bitte korrigieren. + CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert. CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. FFSheetName: Name + SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} SheetTitleNew tid@TermIdentifier courseShortHand@Text : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt @@ -18,11 +20,22 @@ SheetNameDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gi SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen? SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. + UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. 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) +SubmissionArchive: Zip-Archiv der Abgabedatei(en) +SubmissionFile: Datei zur Abgabe +SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. + +EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. +NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet. + diff --git a/models b/models index de3c17b88..3e0c09966 100644 --- a/models +++ b/models @@ -6,6 +6,7 @@ User displayName Text maxFavourites Int default=12 UniqueAuthentication plugin ident + UniqueEmail email UserAdmin user UserId school SchoolId @@ -147,7 +148,7 @@ SubmissionUser UniqueSubmissionUser userId submissionId SubmissionGroup courseId CourseId - name Text + name Text Maybe SubmissionGroupEdit user UserId time UTCTime diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 4f3b8bf9a..b6a3b148f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -332,7 +332,7 @@ getSheetDelR tid csh shn = do (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - setMessageI $ MsgSheetDelOk tident csh shn + addMessageI "info" $ MsgSheetDelOk tident csh shn redirect $ CSheetR tid csh SheetListR _other -> do submissionno <- runDB $ do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index a321b4ddd..142a35bf7 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} module Handler.Submission where @@ -34,46 +35,123 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink +import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as Map import System.FilePath -import Colonnade +import Colonnade hiding (bool) import Yesod.Colonnade import qualified Text.Blaze.Html5.Attributes as HA -makeSubmissionForm :: Bool -> Form (Source Handler File) -makeSubmissionForm unpackZips = identForm FIDsubmission $ \html -> do - flip (renderAForm FormStandard) html $ - areq (zipFileField unpackZips) "Zip Archiv zur Abgabe" Nothing +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 <* submitButton + where + groupNr + | Arbitrary{..} <- grouping = pred maxParticipants + | 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 - shid <- runDB $ do - shid <- fetchSheetId tid csh shn + (Entity shid Sheet{..}) <- runDB $ do + sheet@(Entity shid _) <- fetchSheet tid csh shn case msmid of - Nothing -> return shid + 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 shid + return sheet let unpackZips = True -- undefined -- TODO - ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips - case res of - (FormSuccess files) -> do - smid <- runDB $ runConduit $ - transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid) - cID <- encrypt smid - redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID - (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml - _other -> return () + ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping + runDB $ do + res' <- case res of + (FormMissing ) -> return $ FormMissing + (FormFailure failmsg) -> 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 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 + 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 + + | otherwise -> return $ FormFailure ["Mismatching number of group participants"] + + + case res' of + (FormSuccess (files,gemails)) -> do + now <- liftIO $ getCurrentTime + smid <- runDB $ do + -- AdHoc + + -- + 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 + 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 + return smid + cID <- encrypt smid + redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml + _other -> return () let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn let formTitle = pageTitle @@ -89,6 +167,10 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do + + + +----------------------------------------------------------------------------------------------- ------------------------- DEMO BELOW diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cfd104d15..1c5c94f1e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -355,7 +355,7 @@ utcTimeField = Field fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -fsm = bfs +fsm = bfs -- TODO: get rid of Bootstrap fsb :: Text -> FieldSettings site fsb = bfs -- Just to avoid annoying Ambiguous Type Errors diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 61c5736dc..24db7ae1a 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -47,3 +47,6 @@ fetchSheet = fetchSheetAux id fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet) fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn + +fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course) +fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourseId)) tid cid shn diff --git a/src/Model/Types.hs b/src/Model/Types.hs index da0073707..449d947d7 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -54,7 +54,7 @@ deriveJSON defaultOptions ''SheetType derivePersistFieldJSON "SheetType" data SheetGroup - = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary + = Arbitrary { maxParticipants :: Int } | RegisteredGroups | NoGroups deriving (Show, Read, Eq)