Group Submissions mostly done, NOT COMPILING

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.
+

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

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

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 :: Bool -> SheetGroup -> Form (Source Handler File, [Text])
-makeSubmissionForm unpackZips = identForm FIDsubmission $ \html -> do
+makeSubmissionForm unpackZips grouping = identForm FIDsubmission $ \html -> do
-    flip (renderAForm FormStandard) html $
+    flip (renderAForm FormStandard) html $ (,)
-      areq (zipFileField unpackZips) "Zip Archiv zur Abgabe" Nothing
+      <$> 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
+  (Entity shid Sheet{..})  <- runDB $ do
-    shid  <- fetchSheetId tid csh shn
+    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
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping
-  case res of
+  runDB $ do
-    (FormSuccess files) -> do
+    res' <- case res of
-      smid <- runDB $ runConduit $
+      (FormMissing )           -> return $ FormMissing
-        transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
+      (FormFailure failmsg)    -> return $ FormFailure failmsgs
-      cID <- encrypt smid
+      (FormSuccess (files,[])) -> return $ FormSuccess (files,[]) -- Type change
-      redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
+      (FormSuccess (files, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+        | (Arbitrary {..}) <- sheetGrouping
-    _other -> return ()
+        , 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
 
 

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

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

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)