From 67ba5509b143f786eb8b8893715834c85bf8659f Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 19:24:44 +0200 Subject: [PATCH] 3rd tick for issue #187 --- src/Handler/Course.hs | 113 ++++++++++++++++++++------------------ src/Handler/Utils/Form.hs | 31 ----------- 2 files changed, 60 insertions(+), 84 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 154c75d10..044f9b391 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,7 +15,7 @@ module Handler.Course where -import Import +import Import hiding (catMaybes) import Control.Lens import Utils.Lens @@ -33,6 +33,9 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.CaseInsensitive as CI + + import Colonnade hiding (fromMaybe,bool) -- import Yesod.Colonnade @@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do (_other) -> return () -- TODO check this! redirect $ CourseR tid ssh csh CShowR + +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +getCourseNewTemplateR mbTid mbSsh mbCsh = + redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid + , ("ssh",).CI.original.unSchoolKey <$> mbSsh + , ("csh",).CI.original <$> mbCsh + ]) + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId @@ -325,59 +336,55 @@ getCourseNewR = do <*> iopt ciField "ssh" <*> iopt ciField "csh" let noTemplateAction = courseEditHandler True Nothing - case params of + case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more! FormMissing -> noTemplateAction - FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) - >> noTemplateAction - FormSuccess (mbTid,mbSsh,mbCsh) -> - getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh - -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = do - uid <- requireAuthId - oldCourses <- runDB $ do - 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 -> do - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - let lecturersSchool = - E.exists $ E.from $ \user -> do - E.where_ $ user E.^. UserLecturerUser E.==. E.val uid - E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool - let courseCreated c = - 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_ [(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) 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 True template + FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> + noTemplateAction + FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do + uid <- requireAuthId + oldCourses <- runDB $ do + 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 -> do + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + let lecturersSchool = + E.exists $ E.from $ \user -> do + E.where_ $ user E.^. UserLecturerUser E.==. E.val uid + E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + let courseCreated c = + 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_ [(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) 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 True template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course. diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 78ddbe393..a6efd53ff 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -121,37 +121,6 @@ linkButton lbl cls url = [whamlet| - {- -combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) -combinedButtonField btns inner csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - (innerRes,innerWdgt) <- inner - let widget = do - [whamlet| - #{csrf} - ^{innerWdgt} -
- $forall bView <- btnViews - ^{fvInput bView} - |] - let result = case (accResult result, innerRes) of - (FormSuccess b, FormSuccess i) -> FormSuccess (b,i) - _ -> FormFailure ["Something went wrong"] -- TODO - return (result,widget) - where - accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a - accResult = Foldable.foldr accResult' FormMissing - - accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] - accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs - -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) buttonForm :: (Button UniWorX a, Show a) => Form a