-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Course.Edit ( getCourseNewR, postCourseNewR , getCEditR, postCEditR ) where import Import import Utils.Form import Handler.Utils import Handler.Utils.Invitations import qualified Data.CaseInsensitive as CI import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Map ((!)) import qualified Data.Map as Map import qualified Control.Monad.State.Class as State import qualified Database.Esqueleto.Legacy as E import Jobs.Queue import Handler.Course.LecturerInvite data CourseForm = CourseForm { cfCourseId :: Maybe CourseId , cfName :: CourseName , cfShort :: CourseShorthand , cfSchool :: SchoolId , cfTerm :: TermId , cfDesc :: Maybe StoredMarkup , cfLink :: Maybe URI , cfVisFrom :: Maybe UTCTime , cfVisTo :: Maybe UTCTime , cfMatFree :: Bool , cfCapacity :: Maybe Int , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] , cfQualis :: [(QualificationId, Int)] } makeLenses_ ''CourseForm courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription , cfLink = courseLinkExternal , cfShort = courseShorthand , cfTerm = courseTerm , cfSchool = courseSchool , cfCapacity = courseCapacity , cfSecret = courseRegisterSecret , cfMatFree = courseMaterialFree , cfVisFrom = courseVisibleFrom , cfVisTo = courseVisibleTo , cfRegFrom = courseRegisterFrom , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ] -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe auch DevOps #1878 , cfQualis = [ (courseQualificationQualification, courseQualificationSortOrder) | CourseQualification{..} <- qualis, courseQualificationCourse == cid ] } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring now <- liftIO getCurrentTime MsgRenderer mr <- getMsgRenderer uid <- liftHandler requireAuthId (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] -- default rights adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool] return (userSchools, qualificationsOptionList elegibleQualifications) (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c _courseOld@Course{..} <- runDB $ get404 cid mayEditTerm <- isAuthorized TermEditR True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True if | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms | otherwise -> return (termsSetField [cfTerm cform], [cfTerm cform]) _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput MassInput{..} (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical) True (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template) mempty where liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) liftEither (Right lid , Just lType) = Right (lid , lType ) liftEither (Left lEmail, mLType ) = Left (lEmail, mLType) liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to" unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType) unliftEither (Right (lid , lType )) = (Right lid , Just lType) unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType ) miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ _ nudge btn = Just $ \csrf -> do (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing let addRes'' = addRes <&> \newDat oldDat -> if | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat) , not $ Set.null existing -> FormFailure [mr MsgCourseLecturerAlreadyAdded] | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat addView' = $(widgetFile "course/lecturerMassInput/add") return (addRes'', addView') miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) usr <- liftHandler . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape -> ListPosition -- ^ Coordinate to delete -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) miDelete = miDeleteList miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition miAddEmpty _ _ _ = Set.empty miLayout :: ListLength -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ 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 "course/lecturerMassInput/layout") miIdent :: Text miIdent = "lecturers" qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False where miIdent :: Text miIdent = "qualifications" miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)]) miAdd nudge submitView csrf = do (formRes, formView) <- aCourseQualiForm nudge Nothing csrf let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) -> let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists] ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ] problems = qidBad ++ ordBad in if null problems then FormSuccess $ pure newDat else FormFailure problems return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add")) miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int) miEdit nudge = aCourseQualiForm nudge . Just miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int) miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout") aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int) aCourseQualiForm nudge mTemplate csrf = do (cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate) (ordRes, ordView) <- mpreq intField ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate) return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form")) (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) _allIOtherCases -> do mbLastTerm <- liftHandler . runDB . runMaybeT $ MaybeT . get =<< MaybeT getCurrentTerm return ( Just $ Just now , Just . toMidnight . termStart <$> mbLastTerm , Just . beforeMidnight . termEnd <$> mbLastTerm , Just . beforeMidnight . termEnd <$> mbLastTerm ) multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (cfCourseId =<< template) <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …" -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) <* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)) (cfDesc <$> template) <*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) (cfLink <$> template) <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgCourseDate) & setTooltip MsgCourseVisibleFromTip) (deepAlt (cfVisFrom <$> template) newVisFrom) <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgCourseDate) & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) <*> apopt checkBoxField (fslI MsgCourseMaterialFree) (cfMatFree <$> template) <* aformSection MsgCourseFormSectionRegistration <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) <*> aopt (textField & cfStrip) (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) & setTooltip MsgCourseSecretTip) (cfSecret <$> template) <*> aopt utcTimeField (fslpI MsgCourseRegisterFrom (mr MsgCourseDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) <*> aopt utcTimeField (fslpI MsgCourseRegisterTo (mr MsgCourseDate) & setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo) <*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgCourseDate) & setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil) <* aformSection MsgCourseFormSectionAdministration <*> lecturerForm <*> qualificationsForm (cfQualis <$> template) return (result, widget) validateCourse :: FormValidator CourseForm (YesodDB UniWorX) () validateCourse = do CourseForm{..} <- State.get uid <- liftHandler requireAuthId userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR guardValidation MsgCourseVisibilityEndMustBeAfterStart $ NTop cfVisFrom <= NTop cfVisTo guardValidation MsgCourseRegistrationEndMustBeAfterStart $ NTop cfRegFrom <= NTop cfRegTo guardValidation MsgCourseDeregistrationEndMustBeAfterStart $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil) unless userAdmin $ do guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers guardValidation MsgCourseEditQualificationFailExists $ not $ hasDuplicates $ fst <$> cfQualis guardValidation MsgCourseEditQualificationFailOrder $ not $ hasDuplicates $ snd <$> cfQualis warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 warnValidation MsgCourseNotAlwaysVisibleDuringRegistration $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button <$> iopt termNewField "tid" <*> iopt ciField "ssh" <*> iopt ciField "csh" let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p getParams = concat [ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ] , [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ] , [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ] ] let noTemplateAction = courseEditHandler' Nothing case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more! FormMissing -> noTemplateAction FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >> noTemplateAction FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do oldCourses <- runDB $ E.select $ E.from $ \course -> do whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh let lecturersCourse = E.exists $ E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId let lecturersSchool = E.exists $ E.from $ \user -> E.where_ $ user E.^. UserFunctionUser E.==. E.val uid E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer let courseCreated c = E.subSelectMaybe . E.from $ \edit -> do -- oldest edit must be creation E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId return $ E.min_ $ edit E.^. CourseEditTime E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer , E.desc $ courseCreated course] -- most recent created course E.limit 1 return course template <- case oldCourses of (oldTemplate:_) -> runDB $ do mbLecs <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey mbQualis <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder] let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis return $ Just $ newTemplate { cfCourseId = Nothing , cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness , cfRegFrom = Nothing , cfRegTo = Nothing , cfDeRegUntil = Nothing } [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) <$> ifNothingM mbTid True existsKey <*> ifNothingM mbSsh True existsKey <*> ifNothingM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse return Nothing courseEditHandler' template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course. getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCEditR = pgCEditR postCEditR = pgCEditR pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html pgCEditR tid ssh csh = do courseData <- runDB $ do mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey mbQualis <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder] return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis -- IMPORTANT: both GET and POST Handler must use the same template, -- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons. courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData -- | Course Creation and Editing -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing), -- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons! courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html courseEditHandler miButtonAction mbCourseForm = do aid <- requireAuthId ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm formResult result $ \case res@CourseForm { cfCourseId = Nothing , cfShort = csh , cfSchool = ssh , cfTerm = tid } -> do -- create new course now <- liftIO getCurrentTime insertOkay <- runDBJobs $ do insertOkay <- let CourseForm{..} = res in insertUnique Course { courseName = cfName , courseDescription = cfDesc , courseLinkExternal = cfLink , courseShorthand = cfShort , courseTerm = cfTerm , courseSchool = cfSchool , courseCapacity = cfCapacity , courseRegisterSecret = cfSecret , courseMaterialFree = cfMatFree , courseVisibleFrom = cfVisFrom , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil } whenIsJust insertOkay $ \cid -> do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) return insertOkay case insertOkay of Just _ -> do -- addMessageI Info $ MsgCourseNewOk tid ssh csh redirect $ CourseR tid ssh csh CShowR Nothing -> addMessageI Warning $ MsgCourseNewDupShort tid ssh csh res@CourseForm { cfCourseId = Just cid , cfShort = csh , cfSchool = ssh , cfTerm = tid } -> do -- edit existing course now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDBJobs $ do old <- get cid case old of Nothing -> addMessageI Error MsgCourseInvalidInput $> False (Just _) -> do updOkay <- let CourseForm{..} = res in myReplaceUnique cid Course { courseName = cfName , courseDescription = cfDesc , courseLinkExternal = cfLink , courseShorthand = cfShort , courseTerm = cfTerm -- dangerous , courseSchool = cfSchool , courseCapacity = cfCapacity , courseRegisterSecret = cfSecret , courseMaterialFree = cfMatFree , courseVisibleFrom = cfVisFrom , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil } case updOkay of (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do deleteWhere [LecturerCourse ==. cid] deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)] let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitleI MsgCourseEditTitle wrapForm formWidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } -- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized upsertCourseQualifications uid cid qualis = do let newQualis = Map.fromList qualis oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications here! Also see DevOps #1878 okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: $logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis $logErrorS "CourseQuali" $ "NEW Course Qualifications:" <> tshow newQualis $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis) -} foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of Just so_new | so_new /= so_old -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association Nothing -> delete k -- existing CourseQualifications may be removed, regardless of school association _ -> return () res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh} | Set.member ssh okSchools -> insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so} $> All True | otherwise -> do addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh pure $ All False _ -> do addMessageI Warning MsgCourseEditQualificationFail pure $ All False pure $ getAll res