{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Handler.Submission.Helper ( submissionHelper ) where import Import import Jobs import Handler.Utils import Handler.Utils.Submission import Handler.Utils.Invitations import Data.Maybe (fromJust) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) import qualified Data.Set as Set import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Text as Text import Text.Blaze (Markup) import qualified Data.Aeson.Types as JSON import Data.Aeson.Lens import Handler.Submission.Download import Handler.Submission.SubmissionUserInvite 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 <- messageIconI Info IconEmail $ if | isLecturer -> MsgEmailInvitationWarningCourseParticipants | otherwise -> MsgEmailInvitationWarningPrevCoSubmittors $(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.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive 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.where_ . E.exists . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.orderBy [E.asc $ user E.^. UserEmail] return user addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail submittorSettings, singleSubSettings :: FieldSettings UniWorX submittorSettings = fslI MsgSubmissionMembers 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' = maybeT submittorsForm $ do restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array) let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt submittorsForm | isLecturer = do -- Form is being used by lecturer; allow Everything™ 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 (addFieldSettings mr & 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 mr & 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 $ Just (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) submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html submissionHelper tid ssh csh shn mcid = do muid <- maybeAuthId msmid <- traverse decrypt mcid actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute let getSheetInfo = 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 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_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid 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.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid 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 (maybe id (Set.insert . Right) muid) (not isLecturer)) & fromMaybe Set.empty , [] , maySubmit , isLecturer , not isLecturer , Nothing, Nothing ) (Nothing, RegisteredGroups) -> do buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do E.on . E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserId return ( csheet , buddies & map (Right . E.unValue) & Set.fromList , [] , maySubmit , isLecturer , not isLecturer , Nothing, Nothing ) (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing) (Just smid, _) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) sub@Submission{..} <- get404 smid let shid' = submissionSheet 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) | muid == Just 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 $ E.just (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 corrector <- join <$> traverse getEntity submissionRatingBy return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector) -- @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) <- do (Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies let formWidget = wrapForm' BtnHandIn formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do (Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid 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 () when ( is _Nothing muid && is _Nothing msubmission && not isLecturer ) notAuthenticated -- 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 (FormSuccess res'@(_, groupMembers)) | groupMembers == subUsersOld -> return $ FormSuccess res' | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members 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.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 E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive 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 GT | not isLecturer -> pure $ mr MsgTooManyParticipants _ -> mempty ] return $ if null failmsgs then FormSuccess res' else FormFailure failmsgs | otherwise -> return $ FormSuccess res' formResultMaybe res' $ \(mFiles, adhocMembers) -> 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 .| extractRatingsMsg .| sinkSubmission muid (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 now <- liftIO getCurrentTime insert_ $ SubmissionEdit muid now sid return sid -- Determine new submission users subUsers <- if | isLecturer -> return adhocMembers | RegisteredGroups <- sheetGrouping -> 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_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return $ submissionGroupUser' E.^. SubmissionGroupUserUser -- SubmissionUser for all group members (pre-registered & ad-hoc) return $ maybe id (Set.insert . Right) muid groupUids | otherwise -> return 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 (Just subUid == muid) $ 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 (Just subUid == muid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated | otherwise -> MsgSubmissionUpdated Just <$> encrypt smid 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 () (Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat $ catMaybes [ Just . sortable (Just "path") (i18nCell MsgFileTitle) $ \(mOrig, mCorr) -> let Just fileTitle' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr) origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr Just isFile = origIsFile <|> corrIsFile in if | Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of Nothing -> cell mempty Just (Entity _ SubmissionFile{..}) | isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget) | otherwise -> i18nCell MsgCorrected , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let origTime = submissionFileModified . entityVal <$> mOrig corrTime = submissionFileModified . entityVal <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in dateTimeCell fileTime ] subDownloadLink :: _ -> _ -> _ -> WidgetFor UniWorX _ subDownloadLink cid sft fileTitle' = liftHandler . runDB . withFileDownloadToken (subDownloadSource tid ssh csh shn cid sft fileTitle') . CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle' submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle 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.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, sf2) smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId) , dbtColonnade = colonnadeFiles cid , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "path" , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> E.coalesce [sf1 E.?. SubmissionFileTitle, sf2 E.?. SubmissionFileTitle] ) , ( "time" , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "GREATEST" ([sf1 E.?. SubmissionFileModified, sf2 E.?. SubmissionFileModified] :: [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 filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent) E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate) E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId) defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID -> let mkUrl sft = toTextUrl <=< withFileDownloadToken' (subArchiveSource tid ssh csh shn cID sft) . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment in $(widgetFile "correction-user") $(widgetFile "submission")