423 lines
23 KiB
Haskell
423 lines
23 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 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 <jost@tcs.ifi.lmu.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)]
|
|
}
|
|
|
|
makeLenses_ ''CourseForm
|
|
|
|
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
|
|
courseToForm (Entity cid Course{..}) lecs lecInvites = 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 ]
|
|
}
|
|
|
|
|
|
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
|
|
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
|
|
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
|
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
|
|
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
|
|
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
|
|
return (lecturerSchools, adminSchools, oldSchool)
|
|
let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
|
|
|
|
(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
|
|
_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 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)
|
|
User{userEmail, userDisplayName, userSurname} <- 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"
|
|
|
|
|
|
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 )
|
|
|
|
(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
|
|
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
|
|
|
|
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 listToMaybe oldCourses of
|
|
(Just oldTemplate) ->
|
|
let newTemplate = courseToForm oldTemplate mempty mempty in
|
|
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
|
|
}
|
|
Nothing -> do
|
|
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
|
<$> ifMaybeM mbTid True existsKey
|
|
<*> ifMaybeM mbSsh True existsKey
|
|
<*> ifMaybeM 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
|
|
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
|
|
-- 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 3) 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
|
|
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
|
|
|
|
insert_ $ CourseEdit aid now cid
|
|
|
|
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
|
|
}
|