499 lines
30 KiB
Haskell
499 lines
30 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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
|