fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix build of Submission.hs

Browse Source
This commit is contained in:
Gregor Kleen 2018-04-11 15:09:20 +02:00
parent 686adfa498
commit 4c4cbd584c
2 changed files with 43 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/de.msg
View File

@ -31,7 +31,7 @@ OnlyUploadOneFile: Bitte nur eine Datei hochladen.
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe 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) SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe SubmissionFile: Datei zur Abgabe
SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt.

79
src/Handler/Submission.hs
View File

@ -28,6 +28,8 @@ import Control.Monad.Trans.State.Strict (StateT)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
@ -36,6 +38,7 @@ import qualified Data.Conduit.List as Conduit
import Data.Conduit.ResumableSink import Data.Conduit.ResumableSink
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as 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 makeSubmissionForm unpackZips grouping = identForm FIDsubmission $ \html -> do
flip (renderAForm FormStandard) html $ (,) flip (renderAForm FormStandard) html $ (,)
<$> areq (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing <$> 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 <* submitButton
where where
groupNr groupNr
@ -86,72 +89,74 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
return sheet return sheet
let unpackZips = True -- undefined -- TODO let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping
runDB $ do mCID <- runDB $ do
res' <- case res of res' <- case res of
(FormMissing ) -> return $ FormMissing (FormMissing ) -> return $ FormMissing
(FormFailure failmsg) -> return $ FormFailure failmsgs (FormFailure failmsgs) -> return $ FormFailure failmsgs
(FormSuccess (files,[])) -> return $ FormSuccess (files,[]) -- Type change (FormSuccess (files,[])) -> return $ FormSuccess (files,[]) -- Type change
(FormSuccess (files, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members (FormSuccess (files, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members
| (Arbitrary {..}) <- sheetGrouping | (Arbitrary {..}) <- sheetGrouping
, length gEMails < maxParticipants -> do -- < since submitting user is already accounted for , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
let gemails = map CI.foldedCase gEMails 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] 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 participants <- fmap prep . E.select . E.from $ \user -> do
E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
isParticipant <- E.sub_select . E.from $ \courseParticipant -> do let
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId isParticipant = E.sub_select . E.from $ \courseParticipant -> do
E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val cid E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUserId
return $ E.countRows E.>. E.val 0 E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val sheetCourseId
hasSubmitted <- E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do return $ E.countRows E.>. E.val (0 :: Int64)
E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId
E.&&. submission E.^. SubmissionSheetId E.==. E.val shid E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId
return $ E.countRows E.>. E.val 0 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)) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
$logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
mr <- getMessageRender mr <- getMessageRender
let failmsgs = flip Map.foldMapWithKey participants $ let failmsgs = flip Map.foldMapWithKey participants $ \email -> \case
\email -> \case Nothing -> [mr $ MsgEMailUnknown $ CI.original email]
Nothing -> [mr $ MsgEMailUnknown $ CI.original email] (Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh]
(Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh] (Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)]
(Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)] _other -> mempty
_other -> mempty return $ if null failmsgs
if null failmsgs then FormSuccess (files, foldMap (\(Just (i,_,_)) -> [i]) participants)
then return $ FormSuccess (files, foldMap (\(Just (i,_,_)) -> [i]) participants) else FormFailure failmsgs
else return $ FormFailure failmsgs
| otherwise -> return $ FormFailure ["Mismatching number of group participants"] | otherwise -> return $ FormFailure ["Mismatching number of group participants"]
case res' of case res' of
(FormSuccess (files,gemails)) -> do (FormSuccess (files,(setFromList -> adhocIds))) -> do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
smid <- runDB $ do smid <- do
-- AdHoc
--
smid <- runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid) smid <- runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid)
insertUnique $ SubmissionUser uid smid insertUnique $ SubmissionUser uid smid
insert $ SubmissionEdit uid now smid -- insert $ SubmissionEdit uid now smid -- sinkSubmission already does this
-- Gruppen Abgaben für Feste Gruppen
groupUids <- fmap setFromList . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do -- 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 $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroupId
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid
E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId
return $ submissionGroupUser' E.^. SubmissionGroupUserUserId return $ submissionGroupUser' E.^. SubmissionGroupUserUserId
forM_ (groupUids :: Set (E.Value UserId)) $ \(E.Value uid') -> void . insertUnique $ SubmissionUser uid' smid
-- Adhoc Gruppen
-- TODO -- SubmissionUser for all group members (pre-registered & ad-hoc)
--TODO: SubmissionUser anlegen!!!! forM_ (groupUids `Set.union` adhocIds) $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
--TODO: Permissions für GruppenAbgabe
return smid return smid
cID <- encrypt smid cID <- encrypt smid
redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID return $ Just cID
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
_other -> return () _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 pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
let formTitle = pageTitle let formTitle = pageTitle