-- SPDX-FileCopyrightText: 2022 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 qualified Database.Esqueleto.Utils as E import Jobs.Queue import Handler.Course.LecturerInvite import qualified Data.Conduit.List as C 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 , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe StoredMarkup , cfAppInstructionFiles :: Maybe FileUploads , cfAppText :: Bool , cfAppFiles :: UploadMode , cfAppRatingsVisible :: Bool , cfCapacity :: Maybe Int , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] } data AllocationCourseForm = AllocationCourseForm { acfAllocation :: AllocationId , acfMinCapacity :: Int , acfAcceptSubstitutes :: Maybe UTCTime , acfDeregisterNoShow :: Bool } makeLenses_ ''CourseForm makeLenses_ ''AllocationCourseForm courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription , cfLink = courseLinkExternal , cfShort = courseShorthand , cfTerm = courseTerm , cfSchool = courseSchool , cfCapacity = courseCapacity , cfSecret = courseRegisterSecret , cfMatFree = courseMaterialFree , cfAllocation = allocationCourseToForm cEnt <$> alloc , cfAppRequired = courseApplicationsRequired , cfAppInstructions = courseApplicationsInstructions , cfAppInstructionFiles , cfAppText = courseApplicationsText , cfAppFiles = courseApplicationsFiles , cfAppRatingsVisible = courseApplicationsRatingsVisible , 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 ] } where cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (view $ _entityVal . _FileReference . _1) where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid return courseAppInstructionFile allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm { acfAllocation = allocationCourseAllocation , acfMinCapacity = allocationCourseMinCapacity , acfAcceptSubstitutes = allocationCourseAcceptSubstitutes , acfDeregisterNoShow = courseDeregisterNoShow } 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 ) let allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm = wFormToAForm $ do muid <- maybeAuthId availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid -> E.exists . E.from $ \allocationCourse -> E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId E.where_ $ termIsActiveE (E.val now) (E.val muid) (term E.^. TermId) E.||. alreadyParticipates E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools return (allocation, alreadyParticipates) let allocationEnabled :: Entity Allocation -> Bool allocationEnabled (Entity _ Allocation{..}) = ( NTop allocationStaffRegisterFrom <= NTop (Just now) && NTop (Just now) <= NTop allocationStaffRegisterTo ) || allocationSchool `elem` adminSchools availableAllocations = availableAllocations' ^.. folded . filtered (allocationEnabled . view _1) . _1 activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1 mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId) mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do cID <- encrypt aId :: Handler CryptoUUIDAllocation return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID currentAllocationAvailable = (\alloc -> any ((== alloc) . entityKey) availableAllocations) . acfAllocation <$> (template >>= cfAllocation) case (currentAllocationAvailable, availableAllocations) of (Nothing, []) -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing _ -> do allocationOptions <- mkOptionList <$> mapM mkAllocationOption (availableAllocations ++ activeAllocations) let explainedAllocationOptions = return allocationOptions `explainOptionList` \allocId -> hoistMaybe . listToMaybe $ do (Entity allocId' Allocation{..}, _) <- availableAllocations' guard $ allocId' == allocId toWidget <$> hoistMaybe allocationStaffDescription doExplain = has (folded . _entityVal . _allocationStaffDescription . _Just) $ availableAllocations ++ activeAllocations allocField | doExplain = explainedSelectionField Nothing explainedAllocationOptions | otherwise = selectField' Nothing $ return allocationOptions userAdmin = not $ null adminSchools mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable allocationForm' = let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a ainp | mayChange = apreq | otherwise = aforcedJust in AllocationCourseForm <$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) <*> aopt utcTimeField (fslI MsgCourseAcceptSubstitutesUntil & setTooltip MsgCourseAcceptSubstitutesUntilTip) (fmap acfAcceptSubstitutes $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation) let addTip :: (MonadHandler m, HandlerSite m ~ UniWorX) => FieldView UniWorX -> m (FieldView UniWorX) addTip = addFieldViewTooltipWidget $(i18nWidgetFile "allocation-participate-tip") hoist (censorM $ traverseOf _head addTip) $ optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate) (is _Just . cfAllocation <$> template) 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 <*> allocationForm <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) <*> aopt (multiFileField' . maybeVoid $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> 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 now <- liftIO getCurrentTime uid <- liftHandler requireAuthId userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId prevAllocation <- fmap join . traverse (lift . getEntity) $ allocationCourseAllocation . entityVal <$> prevAllocationCourse oldAllocatedCapacity <- if | Just (Entity _ Allocation{..}) <- prevAllocation , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse , NTop allocationStaffAllocationTo <= NTop (Just now) , NTop allocationRegisterByCourse > NTop (Just now) -> lift $ Just . courseCapacity <$> getJust allocationCourseCourse | otherwise -> return Nothing let oldAllocation = do Entity allocId Allocation{..} <- prevAllocation guard $ NTop (Just now) > NTop allocationStaffRegisterTo pure $ Just allocId oldAllocatedMinCapacity = do Entity _ Allocation{..} <- prevAllocation Entity _ AllocationCourse{..} <- prevAllocationCourse guard $ NTop (Just now) > NTop allocationStaffRegisterTo pure $ Just allocationCourseMinCapacity guardValidation MsgCourseVisibilityEndMustBeAfterStart $ NTop cfVisFrom <= NTop cfVisTo guardValidation MsgCourseRegistrationEndMustBeAfterStart $ NTop cfRegFrom <= NTop cfRegTo guardValidation MsgCourseDeregistrationEndMustBeAfterStart $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil) guardValidation MsgCourseAllocationRequiresCapacity $ is _Nothing cfAllocation || is _Just cfCapacity guardValidation MsgCourseAllocationTermMustMatch $ maybe True (== cfTerm) newAllocationTerm unless userAdmin $ do guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers guardValidation MsgCourseAllocationCapacityMayNotBeChanged $ maybe True (== cfCapacity) oldAllocatedCapacity guardValidation MsgAllocationStaffRegisterToExpiredAllocation $ maybe True (== fmap acfAllocation cfAllocation) oldAllocation guardValidation MsgAllocationStaffRegisterToExpiredMinCapacity $ maybe True (== fmap acfMinCapacity cfAllocation) oldAllocatedMinCapacity warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 warnValidation MsgCourseNotAlwaysVisibleDuringRegistration $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo warnValidation MsgCourseApplicationInstructionsRecommended $ (is _Just cfAppInstructions || is _Just cfAppInstructionFiles) || not (cfAppText || isn't _NoUpload cfAppFiles) 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 Nothing 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 mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation -- 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 , courseApplicationsRequired = cfAppRequired , courseApplicationsInstructions = cfAppInstructions , courseApplicationsText = cfAppText , courseApplicationsFiles = cfAppFiles , courseApplicationsRatingsVisible = cfAppRatingsVisible , courseVisibleFrom = cfVisFrom , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil , courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation } 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 upsertAllocationCourse cid $ cfAllocation res 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 , courseApplicationsRequired = cfAppRequired , courseApplicationsInstructions = cfAppInstructions , courseApplicationsText = cfAppText , courseApplicationsFiles = cfAppFiles , courseApplicationsRatingsVisible = cfAppRatingsVisible , courseVisibleFrom = cfVisFrom , courseVisibleTo = cfVisTo , courseRegisterFrom = cfRegFrom , courseRegisterTo = cfRegTo , courseDeregisterUntil = cfDeRegUntil , courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation } 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 let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ] in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res upsertAllocationCourse cid $ cfAllocation res 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 } upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX () upsertAllocationCourse cid = \case Just AllocationCourseForm{..} -> do prevAllocationCourse <- getBy $ UniqueAllocationCourse cid void $ upsert AllocationCourse { allocationCourseAllocation = acfAllocation , allocationCourseCourse = cid , allocationCourseMinCapacity = acfMinCapacity , allocationCourseAcceptSubstitutes = acfAcceptSubstitutes , allocationCourseOverrideSumCapacity = Nothing } [ AllocationCourseAllocation =. acfAllocation , AllocationCourseCourse =. cid , AllocationCourseMinCapacity =. acfMinCapacity , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes ] when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $ queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid Nothing -> deleteWhere [ AllocationCourseCourse ==. cid ]