-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Submission.Create ( getCorrectionsCreateR, postCorrectionsCreateR ) where import Import hiding (link) -- import System.FilePath (takeFileName) import Jobs import Handler.Utils hiding (colSchool) import qualified Data.Set as Set import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Control.Monad.State.Class as State import qualified Database.Esqueleto.Legacy as E import Data.List (genericLength) getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ isCorrector E.||. isLecturer E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList opts = do opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts MsgRenderer mr <- getMsgRenderer return . mkOptionList $ do (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' let tid' = mr $ ShortTermIdentifier (unTermKey tid) return Option { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn , optionInternalValue = sid , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) } MsgRenderer mr <- getMsgRenderer ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgSubmissionPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing) case pseudonymRes of FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do allDone <- fmap getAll . execWriterT $ do forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") tell . All $ null invalids WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText lift . lift . tell . All $ null unknown now <- liftIO getCurrentTime let sps' :: [[SheetPseudonym]] duplicate :: Set Pseudonym ( sps' , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do known <- State.gets $ Map.member sheetPseudonymPseudonym State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) return $ bool (p :) id known ps submissionPrototype = Submission { submissionSheet = sid , submissionRatingPoints = Nothing , submissionRatingComment = Nothing , submissionRatingBy = Just uid , submissionRatingAssigned = Just now , submissionRatingTime = Nothing } unless (null duplicate) $ addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates") existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') E.&&. submission E.^. SubmissionSheet E.==. E.val sid return submissionUser unless (null existingSubUsers) . mapReaderT lift $ do (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers let trigger = [whamlet|_{MsgSheetCreateExisting}|] content = Right $(widgetFile "messages/submissionCreateExisting") addMessageModal Warning trigger content let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' forM_ sps'' $ \spGroup -> let sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup in case sheetGrouping of Arbitrary maxSize -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (genericLength spGroup > maxSize) $ addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc RegisteredGroups -> do let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup groups <- E.select . E.from $ \submissionGroup -> do E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) return $ submissionGroup E.^. SubmissionGroupId groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) return $ submissionGroupUser E.^. SubmissionGroupUserUser if | [_] <- groups , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser { submissionUserUser = sheetUser , submissionUserSubmission = subId } forM_ groupUsers $ \subUid -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId audit $ TransactionSubmissionUserEdit subId subUid when (null groups) $ addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc | length groups < 2 -> do forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) lift . lift . tell $ All False | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc NoGroups -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (length spGroup > 1) $ addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc when allDone $ redirect CorrectionsGradeR let pseudonymForm = wrapForm pseudonymWidget def { formAction = Just $ SomeRoute CorrectionsCreateR , formEncoding = pseudonymEncoding } siteLayoutMsg MsgSubmissionCorrCreate $ do setTitleI MsgSubmissionCorrCreate $(widgetFile "corrections-create") where partitionEithers' :: [[Either a b]] -> ([[b]], [a]) partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym]) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws) = runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws where toPseudonym w' w | Just res <- w ^? _PseudonymText = return $ Just res | otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords)