diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 492995e80..62a2bf89d 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -326,7 +326,7 @@ getCourseNewR = do FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml) >> noTemplateAction FormSuccess (csh,mbTid,mbSsh) -> do - tid <- ifJustM Nothing mbTid $ \tid -> + tid <- ifMaybeM mbTid Nothing $ \tid -> case termFromText tid of Left err -> addMessage "error" (toHtml err) >> return Nothing Right t -> return $ Just $ TermKey t @@ -336,7 +336,7 @@ getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Ha getCourseNewTemplateR mbTid mbSsh csh = do uid <- requireAuthId oldCourses <- runDB $ do - E.select $ E.from $ \(course) -> do + E.select $ E.from $ \course -> do E.where_ $ course E.^. CourseShorthand E.==. E.val csh whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -348,36 +348,45 @@ getCourseNewTemplateR mbTid mbSsh csh = do E.sub_select . 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_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer schools of lecturer - , E.desc $ courseCreated course] -- most recent created course + E.orderBy [ 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 - t@(Just _) -> return t -- TODO: modify template, eg. current TID + (Just oldTemplate) -> + let newTemplate = (courseToForm oldTemplate) 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 $ (,,) - <$> ifJustM True mbTid existsKey - <*> ifJustM True mbSsh existsKey - <*> ((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 tidOk==True otherwise - unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh - when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse - return Nothing + (tidOk,sshOk,cshOk) <- runDB $ (,,) + <$> ifMaybeM mbTid True existsKey + <*> ifMaybeM mbSsh True existsKey + <*> ((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 csh + when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse + return Nothing courseEditHandler True template postCourseNewR :: Handler Html -postCourseNewR = courseEditHandler False Nothing +postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course. -getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCEditR tid ssh csh = do - course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh - courseEditHandler True course +getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCEditR = pgCEditR True +postCEditR = pgCEditR False -postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCEditR tid ssh csh = do +pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html +pgCEditR isGetReq tid ssh csh = do course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh - courseEditHandler False course + -- 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 isGetReq $ courseToForm <$> course courseDeleteHandler :: Handler Html -- not called anywhere yet @@ -391,12 +400,14 @@ courseDeleteHandler = undefined redirect $ TermCourseListR $ cfTerm res -} -courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html -courseEditHandler isGet course = do - -- isGet <- isWriteRequest - -- $logDebug "€€€€€€ courseEditHandler started" + +-- | 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 :: Bool -> Maybe CourseForm -> Handler Html +courseEditHandler isGet mbCourseForm = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! - ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm + ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm case result of (FormSuccess res@( CourseForm { cfCourseId = Nothing @@ -447,7 +458,7 @@ courseEditHandler isGet course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTerm = cfTerm res + , courseTerm = cfTerm res -- dangerous , courseSchool = cfSchool res , courseCapacity = cfCapacity res , courseRegisterSecret = cfSecret res @@ -489,9 +500,8 @@ data CourseForm = CourseForm , cfDeRegUntil :: Maybe UTCTime } -courseToForm :: MonadCrypto m => Entity Course -> m CourseForm -courseToForm (Entity cid Course{..}) = do - return $ CourseForm +courseToForm :: Entity Course -> CourseForm +courseToForm (Entity cid Course{..}) = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription @@ -515,6 +525,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] ] + let termsField = case template of + (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform] + _allOtherCases -> termsActiveField (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) @@ -525,7 +538,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) + <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 74f54c2fa..ed570c134 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -218,14 +218,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} return . fromRational $ round (sci * 100) % 100 -termActiveField :: Field Handler TermId -termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +termsActiveField :: Field Handler TermId +termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName -termsField :: [TermId] -> Field Handler TermId -termsField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName +termsSetField :: [TermId] -> Field Handler TermId +-- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName +termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ] -termActiveOld :: Field Handler TermIdentifier -termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +-- termActiveOld :: Field Handler TermIdentifier +-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName termNewField :: Field Handler TermIdentifier termNewField = checkMMap checkTerm termToText textField diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 6f43c5258..7a37a93b7 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -336,9 +336,9 @@ instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText {- Must be defined in a later module: -termField :: Field (HandlerT UniWorX IO) TermIdentifier -termField = checkMMap (return . termFromText) termToText textField - -- TODO: this is too simple and inconvenient, use selector and year picker + termField :: Field (HandlerT UniWorX IO) TermIdentifier + termField = checkMMap (return . termFromText) termToText textField + See Handler.Utils.Form.termsField and termActiveField -} diff --git a/src/Utils.hs b/src/Utils.hs index f28bc9062..50a95d4b1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -300,9 +300,9 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () -ifJustM :: Monad m => b -> Maybe a -> (a -> m b) -> m b -ifJustM dft Nothing _ = return dft -ifJustM _ (Just x) act = act x +ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM +ifMaybeM Nothing dft _ = return dft +ifMaybeM (Just x) _ act = act x maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act