3rd tick for issue #187
This commit is contained in:
SJost
parent
b87c3c4ca7
commit
67ba5509b1
@ -15,7 +15,7 @@
|
|||||||
|
|
||||||
module Handler.Course where
|
module Handler.Course where
|
||||||
|
|
||||||
import Import
|
import Import hiding (catMaybes)
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
@ -33,6 +33,9 @@ import Data.Maybe
|
|||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
|
||||||
import Colonnade hiding (fromMaybe,bool)
|
import Colonnade hiding (fromMaybe,bool)
|
||||||
-- import Yesod.Colonnade
|
-- import Yesod.Colonnade
|
||||||
|
|
||||||
@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do
|
|||||||
(_other) -> return () -- TODO check this!
|
(_other) -> return () -- TODO check this!
|
||||||
redirect $ CourseR tid ssh csh CShowR
|
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 :: Handler Html -- call via toTextUrl
|
||||||
getCourseNewR = do
|
getCourseNewR = do
|
||||||
uid <- requireAuthId
|
uid <- requireAuthId
|
||||||
@ -325,59 +336,55 @@ getCourseNewR = do
|
|||||||
<*> iopt ciField "ssh"
|
<*> iopt ciField "ssh"
|
||||||
<*> iopt ciField "csh"
|
<*> iopt ciField "csh"
|
||||||
let noTemplateAction = courseEditHandler True Nothing
|
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
|
FormMissing -> noTemplateAction
|
||||||
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml)
|
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
|
||||||
>> noTemplateAction
|
noTemplateAction
|
||||||
FormSuccess (mbTid,mbSsh,mbCsh) ->
|
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
|
||||||
getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
|
uid <- requireAuthId
|
||||||
|
oldCourses <- runDB $ do
|
||||||
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
|
E.select $ E.from $ \course -> do
|
||||||
getCourseNewTemplateR mbTid mbSsh mbCsh = do
|
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||||
uid <- requireAuthId
|
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
||||||
oldCourses <- runDB $ do
|
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
||||||
E.select $ E.from $ \course -> do
|
let lecturersCourse =
|
||||||
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
E.exists $ E.from $ \lecturer -> do
|
||||||
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||||
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||||
let lecturersCourse =
|
let lecturersSchool =
|
||||||
E.exists $ E.from $ \lecturer -> do
|
E.exists $ E.from $ \user -> do
|
||||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
|
||||||
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
||||||
let lecturersSchool =
|
let courseCreated c =
|
||||||
E.exists $ E.from $ \user -> do
|
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
||||||
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
|
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
||||||
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
return $ E.min_ $ edit E.^. CourseEditTime
|
||||||
let courseCreated c =
|
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
||||||
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
||||||
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
, E.desc $ courseCreated course] -- most recent created course
|
||||||
return $ E.min_ $ edit E.^. CourseEditTime
|
E.limit 1
|
||||||
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
return course
|
||||||
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
template <- case listToMaybe oldCourses of
|
||||||
, E.desc $ courseCreated course] -- most recent created course
|
(Just oldTemplate) ->
|
||||||
E.limit 1
|
let newTemplate = (courseToForm oldTemplate) in
|
||||||
return course
|
return $ Just $ newTemplate
|
||||||
template <- case listToMaybe oldCourses of
|
{ cfCourseId = Nothing
|
||||||
(Just oldTemplate) ->
|
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
||||||
let newTemplate = (courseToForm oldTemplate) in
|
, cfRegFrom = Nothing
|
||||||
return $ Just $ newTemplate
|
, cfRegTo = Nothing
|
||||||
{ cfCourseId = Nothing
|
, cfDeRegUntil = Nothing
|
||||||
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
}
|
||||||
, cfRegFrom = Nothing
|
Nothing -> do
|
||||||
, cfRegTo = Nothing
|
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
||||||
, cfDeRegUntil = Nothing
|
<$> ifMaybeM mbTid True existsKey
|
||||||
}
|
<*> ifMaybeM mbSsh True existsKey
|
||||||
Nothing -> do
|
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
||||||
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
||||||
<$> ifMaybeM mbTid True existsKey
|
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
||||||
<*> ifMaybeM mbSsh True existsKey
|
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
|
||||||
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
|
||||||
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
return Nothing
|
||||||
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
courseEditHandler True template
|
||||||
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
|
|
||||||
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
|
|
||||||
return Nothing
|
|
||||||
courseEditHandler True template
|
|
||||||
|
|
||||||
postCourseNewR :: Handler Html
|
postCourseNewR :: Handler Html
|
||||||
postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.
|
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}>
|
-- <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 a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
|
||||||
buttonForm :: (Button UniWorX a, Show a) => Form a
|
buttonForm :: (Button UniWorX a, Show a) => Form a
|
||||||
|
|||||||
Reference in New Issue
Block a user