{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-} module Handler.Submission where import Import import Jobs -- import Yesod.Form.Bootstrap3 import Handler.Utils import Handler.Utils.Delete import Handler.Utils.Submission import Handler.Utils.Invitations -- import Control.Monad.Trans.Maybe -- import Control.Monad.State.Class -- import Control.Monad.Trans.State.Strict (StateT) import Data.Maybe (fromJust) -- import qualified Data.Maybe import qualified Data.Text.Encoding as Text import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) import qualified Data.Conduit.List as Conduit -- import Data.Conduit.ResumableSink -- import Data.Set (Set) import qualified Data.Set as Set import Data.Map ((!), (!?)) import qualified Data.Map as Map -- import Data.Bifunctor import Text.Blaze (Markup) import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) -- import Colonnade hiding (bool, fromMaybe) -- import qualified Yesod.Colonnade as Yesod -- import qualified Text.Blaze.Html5.Attributes as HA -- DEPRECATED: We always show all edits! -- numberOfSubmissionEditDates :: Int64 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. instance IsInvitableJunction SubmissionUser where type InvitationFor SubmissionUser = Submission data InvitableJunction SubmissionUser = JunctionSubmissionUser deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData SubmissionUser = InvDBDataSubmissionUser deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso (\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser)) (\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..}) instance ToJSON (InvitableJunction SubmissionUser) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction SubmissionUser) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData SubmissionUser) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance FromJSON (InvitationDBData SubmissionUser) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance ToJSON (InvitationTokenData SubmissionUser) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } instance FromJSON (InvitationTokenData SubmissionUser) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } submissionUserInvitationConfig :: InvitationConfig SubmissionUser submissionUserInvitationConfig = InvitationConfig{..} where invitationRoute (Entity subId Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse cID <- encrypt subId return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR invitationResolveFor _ = do cRoute <- getCurrentRoute case cRoute of Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do subId <- decrypt cID bool notFound (return subId) =<< existsKey subId _other -> error "submissionUserInvitationConfig called from unsupported route" invitationSubject (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse itAuthority <- Right <$> liftHandler requireAuthId itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) let itExpiresAt = Nothing itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName invitationUltDest (Entity subId Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse cID <- encrypt subId return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode <*> wFormToAForm submittorsForm where miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = do invWarnMsg <- messageI Warning MsgEmailInvitationWarning $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/submissionUsers/cellKnown") miLayout :: ListLength -> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state -> Map ListPosition Widget -- ^ Cell widgets -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons -> Map (Natural, ListPosition) Widget -- ^ Addition widgets -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout") miIdent :: Text miIdent = "submittors" courseUsers :: E.SqlQuery (E.SqlExpr (Entity User)) courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.orderBy [E.asc $ user E.^. UserEmail] return user previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) previousCoSubmittors uid = E.from $ \(user `E.InnerJoin` submissionUser `E.InnerJoin` submission `E.InnerJoin` sheet) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.&&. sheet E.^. SheetCourse E.==. E.val cid E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser E.where_ . E.exists . E.from $ \submissionUser' -> E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.orderBy [E.asc $ user E.^. UserEmail] return user addField, addFieldLecturer :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) addField = addField' False addFieldLecturer = addField' True addField' isAdmin uid = multiUserField True . Just $ if | isAdmin -> courseUsers | otherwise -> previousCoSubmittors uid addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX addFieldSettings = fslI MsgSubmissionMembers submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip singleSubSettings = fslI MsgSubmissionMember maxSize | Arbitrary{..} <- grouping = Just maxParticipants | otherwise = Nothing mayEdit = is _Arbitrary grouping submittorSettings' | maxSize > Just 1 = submittorSettings | otherwise = singleSubSettings miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX) miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) submittorsForm | isLecturer = do -- Form is being used by lecturer; allow Everything™ uid <- liftHandler requireAuthId let miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd nudge btn csrf = do MsgRenderer mr <- getMsgRenderer (addRes, addView) <- mpreq (addFieldLecturer uid) (addFieldSettings & addName (nudge "emails")) Nothing let addRes' = addRes <&> \newData oldData -> if | existing <- newData `Set.intersection` Set.fromList oldData , not $ Set.null existing -> FormFailure [mr MsgSubmissionUserAlreadyAdded] | otherwise -> FormSuccess $ Set.toList newData return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) mRoute <- getCurrentRoute submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers) MsgRenderer mr <- getMsgRenderer return $ submittors >>= \submittors' -> if | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] | otherwise -> FormSuccess $ Set.fromList submittors' | otherwise = do uid <- liftHandler requireAuthId mRoute <- getCurrentRoute let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do MsgRenderer mr <- getMsgRenderer (addRes, addView) <- mpreq (addField uid) (addFieldSettings & addName (nudge "emails")) Nothing let addRes' = addRes <&> \newData oldData -> if | existing <- newData `Set.intersection` setOf folded oldData , not $ Set.null existing -> FormFailure [mr MsgSubmissionUserAlreadyAdded] | otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) miCell :: ListPosition -> Either UserEmail UserId -> Maybe () -> (Text -> Text) -> Form () miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat) miDelete :: Map ListPosition (Either UserEmail UserId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete dat delPos = do guard mayEdit guard $ Map.size dat > 1 -- User may drop from submission only if it already exists; no directly creating submissions for other people guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid miDeleteList dat delPos miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize miAddEmpty _ _ _ = Set.empty miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction = miButtonAction' mRoute postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) postProcess valMap | is _Just msmid , resultUsers == prefillUsers = resultUsers | Just maxSize' <- maxSize , fromIntegral maxSize' >= Set.size resultUsers = resultUsers | Just maxSize' <- maxSize = let resultUsers' = Set.take (fromIntegral maxSize') resultUsers in if | Set.member (Right uid) resultUsers' -> resultUsers' | otherwise -> Set.insert (Right uid) $ Set.take (pred $ fromIntegral maxSize') resultUsers' | otherwise = Set.singleton $ Right uid where resultUsers = setOf (folded . _1) valMap when (maxSize > Just 1) $ wformMessage =<< messageI Info MsgCosubmittorTip fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers) getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR = postSubmissionNewR postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubShowR = postSubShowR postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId sid <- runDB $ do shid <- fetchSheetId tid ssh csh shn submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId E.&&. submission E.^. SubmissionSheet E.==. E.val shid return $ submission E.^. SubmissionId case submissions of (E.Value sid : _) -> return sid [] -> notFound cID <- encrypt sid redirect $ CSubmissionR tid ssh csh shn cID SubShowR submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html submissionHelper tid ssh csh shn mcid = do uid <- requireAuthId msmid <- traverse decrypt mcid actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid E.&&. submission E.^. SubmissionSheet E.==. E.val shid return $ submission E.^. SubmissionId case (msmid, submissions) of (Nothing, E.Value smid : _) -> do cID <- encrypt smid addMessageI Info MsgSubmissionAlreadyExists redirect $ CSubmissionR tid ssh csh shn cID SubShowR _other -> return () case (msmid, sheetGrouping) of (Nothing, Arbitrary maxBuddies) -> do -- fetch buddies from previous submission in this course buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.limit 1 return $ submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserId return ( csheet , buddies & map (Right . E.unValue) & Set.fromList & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (Set.insert $ Right uid) (not isLecturer)) & fromMaybe Set.empty , [] , maySubmit , isLecturer , not isLecturer ) (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer) -- TODO: Return registered group members (Just smid, _) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid unless (shid == shid') $ invalidArgsI [MsgSubmissionWrongSheet] -- fetch buddies from current submission (Any isOwner, buddies) <- do submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserId let breakUserFromBuddies (E.Value userID) | uid == userID = (Any True , mempty ) | otherwise = (mempty , Set.singleton $ Right userID) invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors lastEdits <- do raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times let userName = if isOwner || maySubmit then E.just $ user E.^. UserDisplayName else E.nothing return (userName, submissionEdit E.^. SubmissionEditTime) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner) -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...) -- Therefore we do not restrict upload behaviour in any way in that case ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies let formWidget = wrapForm' BtnHandIn formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do -- Determine old submission users subUsersOld <- if | Just smid <- msmid -> Set.union <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)) | otherwise -> return Set.empty res' <- case res of FormMissing -> return FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs -- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students) (FormSuccess res'@(_, groupMembers)) | groupMembers == subUsersOld -> return $ FormSuccess res' | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(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_ $ (user E.^. UserId) `E.in_` E.valList gIds let isParticipant = E.exists . E.from $ \courseParticipant -> do E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.&&. submission E.^. SubmissionSheet E.==. E.val shid case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 Nothing -> return () Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants mr <- getMessageRender let failmsgs = (concat :: [[Text]] -> [Text]) [ flip Map.foldMapWithKey participants $ \email -> \case -- Nothing -> pure . mr $ MsgEMailUnknown email (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email _other -> mempty , case fromIntegral (Map.size participants) `compare` maxParticipants of LT -> mempty _ -> pure $ mr MsgTooManyParticipants ] return $ if null failmsgs then FormSuccess res' else FormFailure failmsgs | otherwise -> return $ FormSuccess res' case res' of (FormSuccess (mFiles, adhocMembers)) -> do smid <- do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -> -- new files runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> do sid <- insert Submission { submissionSheet = shid , submissionRatingPoints = Nothing , submissionRatingComment = Nothing , submissionRatingBy = Nothing , submissionRatingAssigned = Nothing , submissionRatingTime = Nothing } audit $ TransactionSubmissionEdit sid shid return sid -- Determine new submission users subUsers <- if | isLecturer -> return adhocMembers | otherwise -> do -- Determine members of pre-registered group groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse return $ submissionGroupUser' E.^. SubmissionGroupUserUser -- SubmissionUser for all group members (pre-registered & ad-hoc) return $ groupUids `Set.union` adhocMembers -- Since invitations carry no data we only need to consider changes to -- the set of users/invited emails -- Otherwise we would have to update old invitations (via -- `sinkInvitationsF`) because their associated @DBData@ might have -- changed forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if -- change is a new user being added to the submission users => send invitation / insert | change `Set.member` subUsers -> case change of Left subEmail -> do -- user does not exist yet => send invitation sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))] return () Right subUid -> do -- user exists and has an id => insert as SubmissionUser and audit insert_ $ SubmissionUser subUid smid audit $ TransactionSubmissionUserEdit smid subUid unless (subUid == uid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid -- change is an old user that is not a submission user anymore => delete invitation / delete | otherwise -> case change of Left subEmail -> deleteInvitation @SubmissionUser smid subEmail Right subUid -> do deleteBy $ UniqueSubmissionUser subUid smid audit $ TransactionSubmissionUserDelete smid subUid unless (subUid == uid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated | otherwise -> MsgSubmissionUpdated return smid cID <- encrypt smid return $ Just cID (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) _other -> return Nothing case mCID of Just cID -> do let showRoute = CSubmissionR tid ssh csh shn cID SubShowR mayShow <- hasReadAccessTo showRoute if | mayShow -> redirect showRoute | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR Nothing -> return () -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr Just isFile = origIsFile <|> corrIsFile in if | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty Just (_, Entity _ File{..}) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) [whamlet|_{MsgFileCorrected}|] | otherwise -> i18nCell MsgCorrected , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let origTime = fileModified . entityVal . snd <$> mOrig corrTime = fileModified . entityVal . snd <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in dateTimeCell fileTime ] coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate)) E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion)) E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) return ((sf1, f1), (sf2, f2)) smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId) , dbtColonnade = colonnadeFiles cid , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "path" , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] ) , ( "time" , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) ) ] , dbtFilter = mempty , dbtFilterUI = mempty , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal $(widgetFile "submission") getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSInviteR = postSInviteR postSInviteR = invitationR submissionUserInvitationConfig getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do (submissionID, isRating) <- runDB $ do submissionID <- submissionMatchesSheet tid ssh csh shn cID isRating <- (== Just submissionID) <$> isRatingFile path when (isUpdate || isRating) $ guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False return (submissionID, isRating) case isRating of True | isUpdate -> runDB $ do file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file | otherwise -> notFound False -> do let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. f E.^. FileTitle E.==. E.val path E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 return f serveOneFile results getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent getSubArchiveR tid ssh csh shn cID sfType = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False sfType' <- ap getMessageRender $ pure sfType archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' let source = do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID case sfType of SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False return f _ -> submissionFileSource submissionID .| Conduit.map entityVal when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating serveSomeFiles archiveName source getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubDelR = postSubDelR postSubDelR tid ssh csh shn cID = do subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID deleteR $ (submissionDeleteRoute $ Set.singleton subId) { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR } getCorrectionsDownloadR :: Handler TypedContent getCorrectionsDownloadR = do -- download all assigned and open submissions uid <- requireAuthId subs <- runDB $ selectKeysList [ SubmissionRatingBy ==. Just uid , SubmissionRatingTime ==. Nothing ] [] when (null subs) $ do addMessageI Info MsgNoOpenSubmissions redirect CorrectionsR submissionMultiArchive $ Set.fromList subs getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubAssignR = postSubAssignR postSubAssignR tid ssh csh shn cID = do let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR sId <- decrypt cID (currentCorrector, sheetCorrectors) <- runDB $ do Submission{submissionRatingBy, submissionSheet} <- get404 sId sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] userCorrector <- traverse getJustEntity submissionRatingBy return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors) $logDebugS "SubAssignR" $ tshow currentCorrector let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $ aopt correctorField (fslI MsgCorrector) (Just currentCorrector) formResult corrResult $ \(fmap entityKey -> mbUserId) -> do when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do now <- liftIO getCurrentTime update sId [ SubmissionRatingBy =. mbUserId , SubmissionRatingAssigned =. (now <$ mbUserId) ] addMessageI Success MsgCorrectorUpdated sub <- getJust sId audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet redirect actionUrl let corrForm = wrapForm' BtnSave corrForm' def { formAction = Just $ SomeRoute actionUrl , formEncoding = corrEncoding , formSubmit = FormSubmit } defaultLayout $ do setTitleI MsgCorrectorAssignTitle $(widgetFile "submission-assign")