3rd tick for issue #187
This commit is contained in:
SJost
parent
b87c3c4ca7
commit
67ba5509b1
@ -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.
|
||||
|
||||
@ -121,37 +121,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
|
||||
-- |]
|
||||
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
|
||||
|
||||
{-
|
||||
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}
|
||||
<div .btn-group>
|
||||
$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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user