Fix build of Submission.hs
This commit is contained in:
Gregor Kleen
parent
686adfa498
commit
4c4cbd584c
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user