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.Function ((&)) import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Map ((!)) import qualified Data.Map as Map import Control.Monad.Trans.Writer (execWriterT) 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 , cfMatFree :: Bool , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe Html , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) , 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 } courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm courseToForm (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 <$> alloc , cfAppRequired = courseApplicationsRequired , cfAppInstructions = courseApplicationsInstructions , cfAppInstructionFiles , cfAppText = courseApplicationsText , cfAppFiles = courseApplicationsFiles , cfAppRatingsVisible = courseApplicationsRatingsVisible , 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 (Left . E.unValue) where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm { acfAllocation = allocationCourseAllocation , acfMinCapacity = allocationCourseMinCapacity } 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 emailField ("" & addName (nudge "user")) Nothing addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk let addRes'' = case (,) <$> addRes <*> addRes' of FormSuccess (CI.mk -> email, mLid) -> let new = maybe (Left email) Right mLid in FormSuccess $ \prev -> if | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course) | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new FormFailure errs -> FormFailure errs FormMissing -> FormMissing 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) ("" & 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 <- messageI Warning 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 (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip])) 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) 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) <*> 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 , 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 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 , 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 let finsert val = do fId <- lift $ either return insert val tell $ Set.singleton fId lift $ void . insertUnique $ CourseAppInstructionFile cid fId keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs 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 ()