753 lines
36 KiB
Haskell
753 lines
36 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Course where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens
|
|
import Utils.Form
|
|
-- import Utils.DB
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.Course
|
|
import Handler.Utils.Delete
|
|
|
|
-- import Data.Time
|
|
-- import qualified Data.Text as T
|
|
import Data.Function ((&))
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import Data.Monoid (Last(..))
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
-- 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 _ 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 mempty
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
|
|
case courseDescription of
|
|
Nothing -> mempty
|
|
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
|
|
|
|
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
|
$ \DBRow{ dbrOutput=(Entity _ 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 _ Course{..}, _, _, _) } -> mappend
|
|
-- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
|
|
-- ( case courseDescription of
|
|
-- Nothing -> mempty
|
|
-- (Just descr) -> cell
|
|
-- [whamlet|
|
|
-- $newline never
|
|
-- <div>
|
|
-- ^{modal "Beschreibung" (Right $ toWidget descr)}
|
|
-- |]
|
|
-- )
|
|
|
|
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
|
$ \DBRow{ dbrOutput=(Entity _ 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 _ Course{..}, _, _, _) } ->
|
|
maybe mempty dateTimeCell 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 _ Course{..}, _, _, _) } ->
|
|
maybe mempty dateTimeCell courseRegisterTo
|
|
|
|
colMembers :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
|
|
Nothing -> MsgCourseMembersCount currentParticipants
|
|
Just limit -> MsgCourseMembersCountLimited currentParticipants limit
|
|
|
|
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
|
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
|
|
$ \DBRow{ dbrOutput=(_, _, 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 ->
|
|
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, DBResult m x ~ ((), Widget) )
|
|
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
|
|
makeCourseTable whereClause colChoices psValidator = do
|
|
muid <- lift 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)
|
|
snd <$> dbTable psValidator DBTable
|
|
{ dbtSQLQuery
|
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
|
, 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)
|
|
, ( "members", 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)
|
|
)
|
|
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
|
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
Just needle -> course2Registered muid tExpr E.==. E.val needle
|
|
)
|
|
, ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
|
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
|
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
|
E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
|
)
|
|
]
|
|
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
|
|
[ Just $ prismAForm (singletonFilter "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch)
|
|
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
|
|
]
|
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
, dbtParams = def
|
|
, dbtIdent = "courses" :: Text
|
|
}
|
|
|
|
getCourseListR :: Handler Html
|
|
getCourseListR = do
|
|
muid <- maybeAuthId
|
|
let colonnade = widgetColonnade $ mconcat
|
|
[ colCourse -- colCourseDescr
|
|
, colDescription
|
|
, colSchoolShort
|
|
, colTerm
|
|
, colCShort
|
|
, maybe mempty (const colRegistered) muid
|
|
]
|
|
whereClause = const $ E.val True
|
|
validator = def
|
|
& defaultSorting [SortDescBy "term",SortAscBy "course"]
|
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseListTitle
|
|
$(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
|
|
, colCShort
|
|
, colDescription
|
|
, colRegFrom
|
|
, colRegTo
|
|
, colMembers
|
|
, 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 [SortAscBy "cshort"]
|
|
coursesTable <- runDB $ 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
|
|
, colCShort
|
|
, colDescription
|
|
, colSchoolShort
|
|
, colRegFrom
|
|
, colRegTo
|
|
, colMembers
|
|
, maybe mempty (const colRegistered) muid
|
|
]
|
|
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
|
|
validator = def
|
|
& defaultSorting [SortAscBy "cshort"]
|
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI . MsgTermCourseListTitle $ tid
|
|
$(widgetFile "courses")
|
|
|
|
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCShowR tid ssh csh = do
|
|
mbAid <- maybeAuthId
|
|
(course,schoolName,participants,registration,lecturers) <- runDB . maybeT notFound $ do
|
|
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
|
|
<- lift . E.select . E.from $
|
|
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
|
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
|
|
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
let numParticipants = E.sub_select . E.from $ \part -> do
|
|
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
return ( E.countRows :: E.SqlExpr (E.Value Int64))
|
|
return (course,school E.^. SchoolName, numParticipants, participant)
|
|
|
|
lecturers <- lift . 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, user E.^. UserSurname, user E.^. UserEmail)
|
|
return (course,schoolName,participants,registration,lecturers)
|
|
|
|
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
|
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
|
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
|
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
|
(regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
|
|
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
|
siteLayout (toWgt $ courseName course) $ do
|
|
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
|
|
$(widgetFile "course")
|
|
|
|
|
|
registerForm :: Bool -> Maybe Text -> Form Bool
|
|
-- unfinished WIP: must take study features if registred and show as mforced field
|
|
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)
|
|
(_sfRes' , _sfView) <- if not registered then return (Nothing,Nothing) else
|
|
bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
|
|
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
|
|
|
|
let widget = $(widgetFile "widgets/register-form/register-form")
|
|
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 Nothing -- TODO
|
|
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
|
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
|
_other -> return () -- TODO check this!
|
|
redirect $ CourseR tid ssh csh CShowR
|
|
|
|
|
|
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 Nothing
|
|
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
|
|
FormMissing -> noTemplateAction
|
|
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
|
|
noTemplateAction
|
|
FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
|
|
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
|
|
oldCourses <- runDB $
|
|
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 ->
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
let lecturersSchool =
|
|
E.exists $ E.from $ \user ->
|
|
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 template
|
|
|
|
postCourseNewR :: Handler Html
|
|
postCourseNewR = courseEditHandler Nothing -- Note: Nothing is safe here, since we will create a new course.
|
|
|
|
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCEditR = pgCEditR
|
|
postCEditR = pgCEditR
|
|
|
|
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
pgCEditR 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 $ courseToForm <$> course
|
|
|
|
|
|
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCDeleteR = postCDeleteR
|
|
postCDeleteR tid ssh csh = do
|
|
Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
deleteR $ (courseDeleteRoute $ Set.singleton cId)
|
|
{ drAbort = SomeRoute $ CourseR tid ssh csh CShowR
|
|
, drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
|
|
}
|
|
|
|
|
|
-- | 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 :: Maybe CourseForm -> Handler Html
|
|
courseEditHandler mbCourseForm = do
|
|
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
|
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm 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 _) -> do
|
|
updOkay <- myReplaceUnique cid 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
|
|
}
|
|
|
|
makeCourseForm :: Maybe CourseForm -> Form CourseForm
|
|
makeCourseForm template = identForm FIDcourse $ \html -> do
|
|
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
|
|
-- let editCid = cfCourseId =<< template -- possible start for refactoring
|
|
|
|
mr <- liftHandlerT getMessageRender -- needed for translation of placeholders
|
|
|
|
userSchools <- liftHandlerT . runDB $ do
|
|
userId <- liftHandlerT requireAuthId
|
|
(fmap concat . sequence)
|
|
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
|
|
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
|
]
|
|
|
|
termsField <- 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 -> liftHandlerT $ 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
|
|
|
|
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
|
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
|
_allIOtherCases -> do
|
|
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
|
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
|
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
|
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
|
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
|
<$> pure (cfCourseId =<< template)
|
|
<*> areq ciField (fslI MsgCourseName) (cfName <$> template)
|
|
<*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
|
|
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
|
<*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL")
|
|
(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 (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
|
|
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
|
<*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
|
|
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
|
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo)
|
|
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
|
|
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
|
|
<* 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"
|
|
-- )
|
|
-- ,
|
|
] ]
|
|
|
|
|
|
--------------------
|
|
-- CourseUserTable
|
|
|
|
type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
|
|
type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool)
|
|
type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId)
|
|
|
|
forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
|
|
forceUserTableType = id
|
|
|
|
userTableQuery :: UserTableWhere -> UserTableExpr
|
|
-> E.SqlQuery ( E.SqlExpr (Entity User)
|
|
, E.SqlExpr (E.Value UTCTime)
|
|
, E.SqlExpr (E.Value (Maybe CourseUserNoteId)))
|
|
userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do
|
|
E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
|
|
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.where_ $ whereClause t
|
|
return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId)
|
|
|
|
instance HasEntity UserTableData User where
|
|
hasEntity = _dbrOutput . _1
|
|
|
|
instance HasUser UserTableData where
|
|
-- hasUser = _entityVal
|
|
hasUser = _dbrOutput . _1 . _entityVal
|
|
|
|
_userTableRegistration :: Lens' UserTableData UTCTime
|
|
_userTableRegistration = _dbrOutput . _2
|
|
|
|
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
|
|
_userTableNote = _dbrOutput . _3
|
|
|
|
-- default Where-Clause
|
|
courseIs :: CourseId -> UserTableWhere
|
|
courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
|
|
|
|
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserComment tid ssh csh =
|
|
sortable (Just "course-user-note") (i18nCell MsgCourseUserNote)
|
|
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } ->
|
|
maybeEmpty mbNoteKey $ const $
|
|
anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
|
|
where
|
|
courseLink = CourseR tid ssh csh . CUserR
|
|
|
|
-- makeCourseUserTable :: (ToSortable h, Functor h) =>
|
|
-- UserTableWhere
|
|
-- -> Colonnade
|
|
-- h
|
|
-- (DBRow
|
|
-- (Entity User, E.Value UTCTime,
|
|
-- E.Value (Maybe CourseUserNoteId)))
|
|
-- (DBCell (HandlerT UniWorX IO) ())
|
|
-- -> PSValidator (HandlerT UniWorX IO) ()
|
|
-- -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
|
|
|
makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget
|
|
makeCourseUserTable whereClause colChoices psValidator =
|
|
-- return [whamlet|TODO|] -- TODO
|
|
-- -- psValidator has default sorting and filtering
|
|
let dbtIdent = "courseUsers" :: Text
|
|
dbtStyle = def
|
|
dbtSQLQuery = userTableQuery whereClause
|
|
dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId
|
|
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId)
|
|
dbtColonnade = colChoices
|
|
dbtSorting = Map.fromList [] -- TODO
|
|
dbtFilter = Map.fromList [] -- TODO
|
|
dbtFilterUI = mempty -- TODO
|
|
dbtParams = def
|
|
in dbTableWidget' psValidator DBTable{..}
|
|
|
|
|
|
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR tid ssh csh = do
|
|
Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
|
|
whereClause = courseIs cid
|
|
colChoices = mconcat
|
|
[ colUserParticipantLink tid ssh csh
|
|
, colUserEmail
|
|
, colUserMatriclenr
|
|
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
|
|
, colUserComment tid ssh csh
|
|
]
|
|
psValidator = def
|
|
tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator
|
|
siteLayout heading $ do
|
|
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
|
|
-- TODO: creat hamlet wrapper
|
|
tableWidget
|
|
|
|
|
|
|
|
getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
|
getCUserR _tid _ssh _csh uCId = do
|
|
-- Has authorization checks (OR):
|
|
--
|
|
-- - User is current member of course
|
|
-- - User has submitted in course
|
|
-- - User is member of registered group for course
|
|
-- - User is member of a tutorial for course
|
|
-- - User is corrector for course
|
|
-- - User is a tutor for course
|
|
-- - User is a lecturer for course
|
|
uid <- decrypt uCId
|
|
User{..} <- runDB $ get404 uid
|
|
-- USE src/utils/Form.formResult
|
|
defaultLayout -- TODO
|
|
[whamlet|
|
|
<p>^{nameWidget userDisplayName userSurname}
|
|
|]
|
|
|
|
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCHiWisR = error "CHiWisR: Not implemented"
|
|
|
|
getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
|
|
getCNotesR = error "CNotesR: Not implemented"
|
|
postCNotesR = error "CNotesR: Not implemented"
|