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 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 Html , cfLink :: Maybe Text , cfVisFrom :: Maybe UTCTime , cfVisTo :: Maybe UTCTime , cfMatFree :: Bool , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe Html , 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 , acfDeregisterNoShow :: Bool } 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 , 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 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 = nub . 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, ) <$> runDB (selectKeysList [TermActive ==. True] []) | otherwise -> return (termsSetField [cfTerm cform], [cfTerm cform]) _allOtherCases -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] []) let miAdd :: ListPosition -> Natural -> (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 . fmap 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 MsgLecturerType & 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 miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True 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 ) (newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) let allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm = wFormToAForm $ do 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_ $ term E.^. TermActive E.||. alreadyParticipates E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools return (allocation, alreadyParticipates) now <- liftIO getCurrentTime 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 userAdmin = not $ null adminSchools mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable allocationForm' = let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a ainp | mayChange = apreq | otherwise = aforcedJust in AllocationCourseForm <$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation) optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template) -- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|] multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (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 & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) (cfLink <$> template) <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate) & setTooltip MsgCourseVisibleFromTip) (cfVisFrom <$> template) <*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgDate) & setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template) <*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) <* aformSection MsgCourseFormSectionRegistration <*> allocationForm <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) <*> uploadModeForm (cfAppFiles <$> template) <*> 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 MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) & setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo) <*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate) & 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 <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> lift $ do prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if | userAdmin -> return Nothing | NTop allocationStaffAllocationTo <= NTop (Just now) , NTop allocationRegisterByCourse > NTop (Just now) -> Just . courseCapacity <$> getJust cid | otherwise -> return Nothing guardValidation MsgCourseRegistrationEndMustBeAfterStart $ NTop cfRegFrom <= NTop cfRegTo guardValidation MsgCourseDeregistrationEndMustBeAfterStart $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil unless userAdmin $ guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers guardValidation MsgCourseAllocationRequiresCapacity $ is _Nothing cfAllocation || is _Just cfCapacity guardValidation MsgCourseAllocationTermMustMatch $ maybe True (== cfTerm) allocationTerm guardValidation MsgCourseAllocationCapacityMayNotBeChanged $ maybe True (== cfCapacity) oldAllocatedCapacity warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 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 $ TermIdentifier 0 Winter -- 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 -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((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 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 MsgInvalidInput $> 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) . traverse_ id $ cfAppInstructionFiles res upsertAllocationCourse cid $ cfAllocation res 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{..} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) doEdit <- if | userAdmin -> return True | Just Allocation{allocationStaffRegisterTo} <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) -> let anyChanges | Just AllocationCourseForm{..} <- cfAllocation , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse = or [ acfAllocation /= allocationCourseAllocation , acfMinCapacity /= allocationCourseMinCapacity ] | otherwise = True in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired) | otherwise -> return True when doEdit $ case cfAllocation of Just AllocationCourseForm{..} -> void $ upsert AllocationCourse { allocationCourseAllocation = acfAllocation , allocationCourseCourse = cid , allocationCourseMinCapacity = acfMinCapacity } [ AllocationCourseAllocation =. acfAllocation , AllocationCourseCourse =. cid , AllocationCourseMinCapacity =. acfMinCapacity ] Nothing | Just (Entity prevId _) <- prevAllocationCourse -> delete prevId _other -> return ()