fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes #190, except for manipualted post-data (ok)

Browse Source
This commit is contained in:
SJost 2018-09-21 16:29:26 +02:00
parent d696c7375e
commit 43598d05c4
4 changed files with 58 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
src/Handler/Course.hs
View File

@ -326,7 +326,7 @@ getCourseNewR = do
FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml) FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
>> noTemplateAction >> noTemplateAction
FormSuccess (csh,mbTid,mbSsh) -> do FormSuccess (csh,mbTid,mbSsh) -> do
tid <- ifJustM Nothing mbTid $ \tid -> tid <- ifMaybeM mbTid Nothing $ \tid ->
case termFromText tid of case termFromText tid of
Left err -> addMessage "error" (toHtml err) >> return Nothing Left err -> addMessage "error" (toHtml err) >> return Nothing
Right t -> return $ Just $ TermKey t Right t -> return $ Just $ TermKey t
@ -336,7 +336,7 @@ getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Ha
getCourseNewTemplateR mbTid mbSsh csh = do getCourseNewTemplateR mbTid mbSsh csh = do
uid <- requireAuthId uid <- requireAuthId
oldCourses <- runDB $ do oldCourses <- runDB $ do
E.select $ E.from $ \(course) -> do E.select $ E.from $ \course -> do
E.where_ $ course E.^. CourseShorthand E.==. E.val csh E.where_ $ course E.^. CourseShorthand E.==. E.val csh
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid 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.sub_select . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
return $ E.min_ $ edit E.^. CourseEditTime 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.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.desc $ courseCreated course] -- most recent created course
E.limit 1 E.limit 1
return course return course
template <- case listToMaybe oldCourses of 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 Nothing -> do
(tidOk,sshOk,cshOk) <- runDB $ (,,) (tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifJustM True mbTid existsKey <$> ifMaybeM mbTid True existsKey
<*> ifJustM True mbSsh existsKey <*> ifMaybeM mbSsh True existsKey
<*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) <*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise 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 sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
return Nothing return Nothing
courseEditHandler True template courseEditHandler True template
postCourseNewR :: Handler Html 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, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR tid ssh csh = do getCEditR = pgCEditR True
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh postCEditR = pgCEditR False
courseEditHandler True course
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
postCEditR tid ssh csh = do pgCEditR isGetReq tid ssh csh = do
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh 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 courseDeleteHandler :: Handler Html -- not called anywhere yet
@ -391,12 +400,14 @@ courseDeleteHandler = undefined
redirect $ TermCourseListR $ cfTerm res redirect $ TermCourseListR $ cfTerm res
-} -}
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do -- | Course Creation and Editing
-- isGet <- isWriteRequest -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- $logDebug "€€€€€€ courseEditHandler started" -- | 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!!! 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 case result of
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Nothing CourseForm { cfCourseId = Nothing
@ -447,7 +458,7 @@ courseEditHandler isGet course = do
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
, courseShorthand = cfShort res , courseShorthand = cfShort res
, courseTerm = cfTerm res , courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res , courseSchool = cfSchool res
, courseCapacity = cfCapacity res , courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res , courseRegisterSecret = cfSecret res
@ -489,9 +500,8 @@ data CourseForm = CourseForm
, cfDeRegUntil :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime
} }
courseToForm :: MonadCrypto m => Entity Course -> m CourseForm courseToForm :: Entity Course -> CourseForm
courseToForm (Entity cid Course{..}) = do courseToForm (Entity cid Course{..}) = CourseForm
return $ CourseForm
{ cfCourseId = Just cid { cfCourseId = Just cid
, cfName = courseName , cfName = courseName
, cfDesc = courseDescription , cfDesc = courseDescription
@ -515,6 +525,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. 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 (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template) <$> pure (cfCourseId =<< template)
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
@ -525,7 +538,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) & setTooltip MsgCourseShorthandUnique)
(cfShort <$> template) (cfShort <$> template)
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)

13
src/Handler/Utils/Form.hs
View File

@ -218,14 +218,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
return . fromRational $ round (sci * 100) % 100 return . fromRational $ round (sci * 100) % 100
termActiveField :: Field Handler TermId termsActiveField :: Field Handler TermId
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
termsField :: [TermId] -> Field Handler TermId termsSetField :: [TermId] -> Field Handler TermId
termsField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName -- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
termActiveOld :: Field Handler TermIdentifier -- termActiveOld :: Field Handler TermIdentifier
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName -- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
termNewField :: Field Handler TermIdentifier termNewField :: Field Handler TermIdentifier
termNewField = checkMMap checkTerm termToText textField termNewField = checkMMap checkTerm termToText textField

6
src/Model/Types.hs
View File

@ -336,9 +336,9 @@ instance FromJSON TermIdentifier where
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
{- Must be defined in a later module: {- Must be defined in a later module:
termField :: Field (HandlerT UniWorX IO) TermIdentifier termField :: Field (HandlerT UniWorX IO) TermIdentifier
termField = checkMMap (return . termFromText) termToText textField termField = checkMMap (return . termFromText) termToText textField
-- TODO: this is too simple and inconvenient, use selector and year picker See Handler.Utils.Form.termsField and termActiveField
-} -}

6
src/Utils.hs
View File

@ -300,9 +300,9 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return () whenIsJust Nothing _ = return ()
ifJustM :: Monad m => b -> Maybe a -> (a -> m b) -> m b ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
ifJustM dft Nothing _ = return dft ifMaybeM Nothing dft _ = return dft
ifJustM _ (Just x) act = act x ifMaybeM (Just x) _ act = act x
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act maybeM dft act mb = mb >>= maybe dft act