Fixes #190, except for manipualted post-data (ok)
This commit is contained in:
SJost
parent
d696c7375e
commit
43598d05c4
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
-}
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user