616 lines
30 KiB
Haskell
616 lines
30 KiB
Haskell
module Handler.Course where
|
|
|
|
import Import hiding (catMaybes)
|
|
|
|
import Control.Lens
|
|
import Utils.Lens
|
|
import Utils.TH
|
|
-- import Utils.DB
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
|
|
-- import Data.Time
|
|
import qualified Data.Text as T
|
|
import Data.Function ((&))
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
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
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
|
|
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
|
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
|
|
|
|
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
|
[whamlet|#{display courseName}|]
|
|
|
|
colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
|
|
course <- view $ _dbrOutput . _1 . _entityVal
|
|
return $ courseCell course
|
|
|
|
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colDescription = sortable Nothing (i18nCell MsgCourseDescription)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
case courseDescription of
|
|
Nothing -> mempty
|
|
(Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
|
|
|
|
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
|
|
|
|
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
|
|
( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
|
|
( case courseDescription of
|
|
Nothing -> mempty
|
|
(Just descr) -> cell
|
|
[whamlet|
|
|
$newline never
|
|
<span style="float:right">
|
|
^{modal "Beschreibung" (Right $ toWidget descr)}
|
|
|]
|
|
)
|
|
|
|
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
|
|
|
|
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
|
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
|
|
|
|
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
|
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
|
|
|
|
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
maybe mempty timeCell courseRegisterFrom
|
|
-- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
|
|
|
|
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
|
cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
|
|
|
|
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
|
|
Nothing -> MsgCourseMembersCount currentParticipants
|
|
Just max -> MsgCourseMembersCountLimited currentParticipants max
|
|
|
|
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
|
|
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered
|
|
|
|
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
|
|
|
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64)
|
|
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
|
|
|
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
|
|
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
|
|
|
|
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
|
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
|
|
makeCourseTable whereClause colChoices psValidator = do
|
|
muid <- maybeAuthId
|
|
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery qin@(course `E.InnerJoin` school) = do
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
let participants = course2Participants qin
|
|
let registered = course2Registered muid qin
|
|
E.where_ $ whereClause (course, participants, registered)
|
|
return (course, participants, registered, school)
|
|
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
|
|
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
|
|
dbTable psValidator $ DBTable
|
|
{ dbtSQLQuery
|
|
, dbtColonnade = colChoices
|
|
, dbtProj
|
|
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
|
|
[ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
|
|
, ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
|
|
, ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
|
|
, ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
|
|
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
|
|
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
|
|
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
|
|
, ( "participants", SortColumn $ course2Participants )
|
|
, ( "registered", SortColumn $ course2Registered muid)
|
|
]
|
|
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
|
|
[ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
, ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
, ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
|
|
-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
|
|
-- )
|
|
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
|
|
emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
|
|
)
|
|
, ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
]
|
|
, dbtStyle = def
|
|
, dbtIdent = "courses" :: Text
|
|
}
|
|
|
|
getCourseListR :: Handler Html
|
|
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
|
|
muid <- maybeAuthId
|
|
let colonnade = widgetColonnade $ mconcat
|
|
[ colCourseDescr
|
|
, colCShort
|
|
, colTerm
|
|
, maybe mempty (const colRegistered) muid
|
|
, colSchool
|
|
]
|
|
whereClause = const $ E.val True
|
|
validator = def
|
|
& defaultSorting [("course", SortAsc), ("term", SortDesc)]
|
|
((), coursesTable) <- makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseListTitle
|
|
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
|
|
$(widgetFile "courses")
|
|
|
|
getTermCurrentR :: Handler Html
|
|
getTermCurrentR = do
|
|
termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
|
|
case fromNullable termIds of
|
|
Nothing -> notFound
|
|
(Just (maximum -> tid)) -> -- getTermCourseListR tid
|
|
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
|
|
|
|
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
|
|
getTermSchoolCourseListR tid ssh = do
|
|
void . runDB $ get404 tid -- Just ensure the term exists
|
|
School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
|
|
muid <- maybeAuthId
|
|
let colonnade = widgetColonnade $ mconcat
|
|
[ dbRow
|
|
, colCShortDescr
|
|
, colRegFrom
|
|
, colRegTo
|
|
, colParticipants
|
|
, maybe mempty (const colRegistered) muid
|
|
]
|
|
whereClause = \(course, _, _) ->
|
|
course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
validator = def
|
|
& defaultSorting [("cshort", SortAsc)]
|
|
((), coursesTable) <- makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
|
$(widgetFile "courses")
|
|
|
|
|
|
getTermCourseListR :: TermId -> Handler Html
|
|
getTermCourseListR tid = do
|
|
void . runDB $ get404 tid -- Just ensure the term exists
|
|
muid <- maybeAuthId
|
|
let colonnade = widgetColonnade $ mconcat
|
|
[ dbRow
|
|
, colCShortDescr
|
|
, colSchoolShort
|
|
, colRegFrom
|
|
, colRegTo
|
|
, colParticipants
|
|
, maybe mempty (const colRegistered) muid
|
|
]
|
|
whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
|
|
validator = def
|
|
& defaultSorting [("cshort", SortAsc)]
|
|
((), coursesTable) <- makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI . MsgTermCourseListTitle $ tid
|
|
$(widgetFile "courses")
|
|
|
|
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCShowR tid ssh csh = do
|
|
mbAid <- maybeAuthId
|
|
(courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
|
|
courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
dependent <- (,,)
|
|
<$> get (courseSchool course) -- join -- just fetch full school name here
|
|
<*> count [CourseParticipantCourse ==. cid] -- join
|
|
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
|
|
Nothing -> return False
|
|
(Just aid) -> do regL <- getBy (UniqueParticipant aid cid)
|
|
return $ isJust regL)
|
|
lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
|
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
|
return $ user E.^. UserDisplayName
|
|
return $ (courseEnt,dependent,E.unValue <$> lecturers)
|
|
let course = entityVal courseEnt
|
|
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
|
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
|
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
|
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
|
defaultLayout $ do
|
|
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
|
|
$(widgetFile "course")
|
|
|
|
|
|
registerForm :: Bool -> Maybe Text -> Form Bool
|
|
registerForm registered msecret extra = do
|
|
(msecretRes', msecretView) <- case msecret of
|
|
(Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
|
|
_ -> return (Nothing,Nothing)
|
|
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
|
|
let widget = $(widgetFile "widgets/registerForm")
|
|
let msecretRes | Just res <- msecretRes' = Just <$> res
|
|
| otherwise = FormSuccess Nothing
|
|
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
|
|
|
|
|
|
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
postCRegisterR tid ssh csh = do
|
|
aid <- requireAuthId
|
|
(cid, course, registered) <- runDB $ do
|
|
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
|
|
return (cid, course, registered)
|
|
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
|
case regResult of
|
|
(FormSuccess codeOk)
|
|
| registered -> do
|
|
runDB $ deleteBy $ UniqueParticipant aid cid
|
|
addMessageI Info MsgCourseDeregisterOk
|
|
| codeOk -> do
|
|
actTime <- liftIO $ getCurrentTime
|
|
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
|
|
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
|
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
|
(_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
|
|
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
|
|
<$> iopt termNewField "tid"
|
|
<*> iopt ciField "ssh"
|
|
<*> iopt ciField "csh"
|
|
let noTemplateAction = courseEditHandler True Nothing
|
|
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 (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.
|
|
|
|
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCEditR = pgCEditR True
|
|
postCEditR = pgCEditR False
|
|
|
|
pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
pgCEditR isGetReq tid ssh csh = do
|
|
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
|
-- 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
|
|
|
|
|
|
getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCDeleteR = error "TODO: implement getCDeleteR"
|
|
postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
postCDeleteR = error "TODO: implement getCDeleteR"
|
|
{- TODO
|
|
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
|
|
, Just cid <- cfCourseId res -> do
|
|
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
|
let cti = toPathPiece $ cfTerm res
|
|
addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
|
redirect $ TermCourseListR $ cfTerm res
|
|
-}
|
|
|
|
|
|
-- | 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 mbCourseForm
|
|
case result of
|
|
(FormSuccess res@(
|
|
CourseForm { cfCourseId = Nothing
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
})) -> do -- create new course
|
|
now <- liftIO getCurrentTime
|
|
insertOkay <- runDB $ insertUnique $ Course
|
|
{ courseName = cfName res
|
|
, courseDescription = cfDesc res
|
|
, courseLinkExternal = cfLink res
|
|
, courseShorthand = cfShort res
|
|
, courseTerm = cfTerm res
|
|
, courseSchool = cfSchool res
|
|
, courseCapacity = cfCapacity res
|
|
, courseRegisterSecret = cfSecret res
|
|
, courseMaterialFree = cfMatFree res
|
|
, courseRegisterFrom = cfRegFrom res
|
|
, courseRegisterTo = cfRegTo res
|
|
, courseDeregisterUntil = cfDeRegUntil res
|
|
}
|
|
case insertOkay of
|
|
(Just cid) -> do
|
|
runDB $ do
|
|
insert_ $ CourseEdit aid now cid
|
|
insert_ $ Lecturer aid cid
|
|
addMessageI Info $ MsgCourseNewOk tid ssh csh
|
|
redirect $ TermCourseListR tid
|
|
Nothing ->
|
|
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
|
|
|
|
(FormSuccess res@(
|
|
CourseForm { cfCourseId = Just cid
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
})) -> do -- edit existing course
|
|
now <- liftIO getCurrentTime
|
|
-- addMessage "debug" [shamlet| #{show res}|]
|
|
success <- runDB $ do
|
|
old <- get cid
|
|
case old of
|
|
Nothing -> addMessageI Error MsgInvalidInput $> False
|
|
(Just oldCourse) -> do
|
|
updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
|
|
Course { courseName = cfName res
|
|
, courseDescription = cfDesc res
|
|
, courseLinkExternal = cfLink res
|
|
, courseShorthand = cfShort res
|
|
, courseTerm = cfTerm res -- dangerous
|
|
, courseSchool = cfSchool res
|
|
, courseCapacity = cfCapacity res
|
|
, courseRegisterSecret = cfSecret res
|
|
, courseMaterialFree = cfMatFree res
|
|
, courseRegisterFrom = cfRegFrom res
|
|
, courseRegisterTo = cfRegTo res
|
|
, courseDeregisterUntil = cfDeRegUntil res
|
|
}
|
|
)
|
|
case updOkay of
|
|
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
|
Nothing -> do
|
|
insert_ $ CourseEdit aid now cid
|
|
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
|
return True
|
|
when success $ redirect $ CourseR tid ssh csh CShowR
|
|
|
|
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
|
(FormMissing) -> return ()
|
|
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseEditTitle
|
|
$(widgetFile "formPage")
|
|
|
|
|
|
data CourseForm = CourseForm
|
|
{ cfCourseId :: Maybe CourseId
|
|
, cfName :: CourseName
|
|
, cfDesc :: Maybe Html
|
|
, cfLink :: Maybe Text
|
|
, cfShort :: CourseShorthand
|
|
, cfTerm :: TermId
|
|
, cfSchool :: SchoolId
|
|
, cfCapacity :: Maybe Int64
|
|
, cfSecret :: Maybe Text
|
|
, cfMatFree :: Bool
|
|
, cfRegFrom :: Maybe UTCTime
|
|
, cfRegTo :: Maybe UTCTime
|
|
, cfDeRegUntil :: Maybe UTCTime
|
|
}
|
|
|
|
courseToForm :: Entity Course -> CourseForm
|
|
courseToForm (Entity cid Course{..}) = CourseForm
|
|
{ cfCourseId = Just cid
|
|
, cfName = courseName
|
|
, cfDesc = courseDescription
|
|
, cfLink = courseLinkExternal
|
|
, cfShort = courseShorthand
|
|
, cfTerm = courseTerm
|
|
, cfSchool = courseSchool
|
|
, cfCapacity = courseCapacity
|
|
, cfSecret = courseRegisterSecret
|
|
, cfMatFree = courseMaterialFree
|
|
, cfRegFrom = courseRegisterFrom
|
|
, cfRegTo = courseRegisterTo
|
|
, cfDeRegUntil = courseDeregisterUntil
|
|
}
|
|
|
|
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
|
newCourseForm template = identForm FIDcourse $ \html -> do
|
|
userSchools <- liftHandlerT . runDB $ do
|
|
userId <- liftHandlerT requireAuthId
|
|
(fmap concat . sequence)
|
|
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
|
|
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
|
]
|
|
|
|
termsField <- liftHandlerT $ case template of
|
|
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
|
|
(Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course
|
|
_courseOld@Course{..} <- runDB $ get404 cid
|
|
mayEditTerm <- isAuthorized TermEditR True
|
|
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
|
|
return $ if
|
|
| (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
|
|
| otherwise -> termsSetField [cfTerm cform]
|
|
_allOtherCases -> return termsAllowedField
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
|
<$> pure (cfCourseId =<< template)
|
|
<*> areq ciField (fslI MsgCourseName) (cfName <$> template)
|
|
<*> aopt htmlField (fslI MsgCourseDescription
|
|
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
|
<*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template)
|
|
<*> areq ciField (fslI MsgCourseShorthand
|
|
-- & addAttr "disabled" "disabled"
|
|
& setTooltip MsgCourseShorthandUnique)
|
|
(cfShort <$> template)
|
|
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
|
|
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
|
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
|
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
|
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
|
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
|
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
|
& setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
|
& setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
|
& setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess courseResult
|
|
| errorMsgs <- validateCourse courseResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<div class="alert__content">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
|
|
|
|
validateCourse :: CourseForm -> [Text]
|
|
validateCourse (CourseForm{..}) =
|
|
[ msg | (False, msg) <-
|
|
[
|
|
( NTop cfRegFrom <= NTop cfRegTo
|
|
, "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
|
|
)
|
|
,
|
|
( NTop cfRegFrom <= NTop cfDeRegUntil
|
|
, "Ende des Abmeldezeitraums muss nach dem Anfang liegen"
|
|
)
|
|
-- No starting date is okay: effective immediately
|
|
-- ( cfHasReg <= (isNothing cfRegFrom)
|
|
-- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
|
|
-- )
|
|
-- ,
|
|
] ]
|
|
|
|
|
|
|
|
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR tid ssh csh = undefined -- TODO
|
|
|
|
|
|
getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
|
getCUserR tid ssh csh uuid = do
|
|
uid <- decrypt uuid
|
|
User{..} <- runDB $ get404 uid
|
|
defaultLayout $
|
|
[whamlet|
|
|
<h1>TODO
|
|
<h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
|
|
|]
|
|
|
|
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCHiWisR tid ssh csh = undefined -- TODO
|