Group Submissions mostly done, NOT COMPILING
This commit is contained in:
SJost
parent
9e2e220f3e
commit
fcd6703752
@ -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.
|
||||
|
||||
|
||||
3
models
3
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user