981 lines
50 KiB
Haskell
981 lines
50 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.Course
|
|
import Handler.Utils.Form.MassInput
|
|
import Handler.Utils.Delete
|
|
import Handler.Utils.Database
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.Table.Columns
|
|
import Database.Esqueleto.Utils
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
-- import Data.Time
|
|
import qualified Data.CaseInsensitive as CI
|
|
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
|
|
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
|
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
|
|
|
|
colCourse :: IsDBTable m a => Colonnade Sortable 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 Sortable 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 Sortable 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 Sortable 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 Sortable 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 Sortable 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 Sortable 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 Sortable CourseTableData (DBCell m a)
|
|
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
|
|
maybe mempty dateTimeCell courseRegisterTo
|
|
|
|
colMembers :: IsDBTable m a => Colonnade Sortable 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 Sortable 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 Int)
|
|
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 Int))
|
|
|
|
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,defSFid,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
|
|
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
|
|
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 Int))
|
|
return (course,school E.^. SchoolName, numParticipants, participant)
|
|
defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
|
|
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
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail)
|
|
return (course,schoolName,participants,registration,entityKey <$> defSFid,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 $ registerForm mbAid registration defSFid $ courseRegisterSecret course
|
|
let regForm = wrapForm regWidget def
|
|
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
|
|
, formEncoding = regEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
|
siteLayout (toWgt $ courseName course) $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
|
$(widgetFile "course")
|
|
|
|
-- | Registration button with maybe a userid if logged in
|
|
-- , maybe existing features if already registered
|
|
-- , maybe some default study features
|
|
-- , maybe a course secret
|
|
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
|
|
-- unfinished WIP: must take study features if registred and show as mforced field
|
|
registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
|
|
-- secret fields
|
|
(msecretRes', msecretView) <- case msecret of
|
|
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
|
|
_ -> return (Nothing,Nothing)
|
|
-- study features
|
|
(msfRes', msfView) <- case loggedin of
|
|
Nothing -> return (Nothing,Nothing)
|
|
Just _ -> bimap Just Just <$> case participant of
|
|
Just CourseParticipant{courseParticipantField=Just sfid}
|
|
-> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
|
|
_other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
|
|
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
|
|
-- button de-/register
|
|
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
|
|
|
|
let widget = $(widgetFile "widgets/register-form/register-form")
|
|
let msecretRes | Just res <- msecretRes' = Just <$> res
|
|
| otherwise = FormSuccess Nothing
|
|
let msfRes | Just res <- msfRes' = res
|
|
| otherwise = FormSuccess Nothing
|
|
-- checks that correct button was pressed, and ignores result of btnRes
|
|
let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
|
|
return (formRes, widget)
|
|
where
|
|
isRegistered = isJust participant
|
|
|
|
|
|
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
postCRegisterR tid ssh csh = do
|
|
aid <- requireAuthId
|
|
(cid, course, registration) <- runDB $ do
|
|
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
registration <- getBy (UniqueParticipant aid cid)
|
|
return (cid, course, entityVal <$> registration)
|
|
let isRegistered = isJust registration
|
|
((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
|
|
formResult regResult $ \(mbSfId,codeOk) -> if
|
|
| isRegistered -> do
|
|
runDB $ deleteBy $ UniqueParticipant aid cid
|
|
addMessageI Info MsgCourseDeregisterOk
|
|
| codeOk -> do
|
|
actTime <- liftIO getCurrentTime
|
|
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
|
|
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
|
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
|
-- addMessage Info $ toHtml $ show regResult -- For debugging only
|
|
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
|
|
courseLecs <- runDB $ do
|
|
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
|
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
|
return $ (,) <$> mbCourse <*> mbLecs
|
|
-- 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 $ uncurry courseToForm <$> courseLecs
|
|
|
|
|
|
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
|
|
formResult result $ \case
|
|
res@CourseForm
|
|
{ cfCourseId = Nothing
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
} -> do -- create new course
|
|
now <- liftIO getCurrentTime
|
|
insertOkay <- runDB $ do
|
|
insertOkay <- 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
|
|
}
|
|
whenIsJust insertOkay $ \cid -> do
|
|
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
|
insert_ $ CourseEdit aid now cid
|
|
return insertOkay
|
|
case insertOkay of
|
|
Just _ -> do
|
|
addMessageI Info $ MsgCourseNewOk tid ssh csh
|
|
redirect $ TermCourseListR tid
|
|
Nothing ->
|
|
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
|
|
|
|
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
|
|
deleteWhere [LecturerCourse ==. cid]
|
|
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
|
insert_ $ CourseEdit aid now cid
|
|
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
|
return True
|
|
when success $ redirect $ CourseR tid ssh csh CShowR
|
|
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseEditTitle
|
|
wrapForm formWidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = formEnctype
|
|
}
|
|
|
|
|
|
data CourseForm = CourseForm
|
|
{ cfCourseId :: Maybe CourseId
|
|
, cfName :: CourseName
|
|
, cfDesc :: Maybe Html
|
|
, cfLink :: Maybe Text
|
|
, cfShort :: CourseShorthand
|
|
, cfTerm :: TermId
|
|
, cfSchool :: SchoolId
|
|
, cfCapacity :: Maybe Int
|
|
, cfSecret :: Maybe Text
|
|
, cfMatFree :: Bool
|
|
, cfRegFrom :: Maybe UTCTime
|
|
, cfRegTo :: Maybe UTCTime
|
|
, cfDeRegUntil :: Maybe UTCTime
|
|
, cfLecturers :: [(UserId, LecturerType)]
|
|
}
|
|
|
|
courseToForm :: Entity Course -> [Lecturer] -> CourseForm
|
|
courseToForm (Entity cid Course{..}) lecs = 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
|
|
, cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
|
}
|
|
|
|
makeCourseForm :: Maybe CourseForm -> Form CourseForm
|
|
makeCourseForm template = identifyForm FIDcourse $ \html -> do
|
|
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
|
|
-- let editCid = cfCourseId =<< template -- possible start for refactoring
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
uid <- liftHandlerT requireAuthId
|
|
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
|
|
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
|
|
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
|
|
let userSchools = lecSchools ++ admSchools
|
|
|
|
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
|
|
|
|
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
|
|
miAdd _ _ nudge btn = Just $ \csrf -> do
|
|
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
|
|
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
|
|
let addRes'' = case (,) <$> addRes <*> addRes' of
|
|
FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
|
|
FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
|
|
| lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
|
|
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
|
|
FormFailure errs -> FormFailure errs
|
|
FormMissing -> FormMissing
|
|
addView' = toWidget csrf >> fvInput addView >> fvInput btn
|
|
return (addRes'', addView')
|
|
|
|
miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
|
|
miCell _ lid defType nudge = \csrf -> do
|
|
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
|
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
|
|
let lrwView' = [whamlet|$newline never
|
|
#{csrf}
|
|
^{nameEmailWidget userEmail userDisplayName userSurname} #
|
|
^{fvInput lrwView}
|
|
|]
|
|
return (lrwRes,lrwView')
|
|
|
|
miDelete :: ListLength -- ^ Current shape
|
|
-> ListPosition -- ^ Coordinate to delete
|
|
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
|
miDelete l pos
|
|
| l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
|
| otherwise = return Map.empty
|
|
|
|
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
|
miAllowAdd _ _ _ = True
|
|
|
|
miButtonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction _ = Nothing
|
|
|
|
|
|
lecturerForm :: AForm Handler [(UserId,LecturerType)]
|
|
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
|
|
MassInput{..}
|
|
(fslI MsgCourseLecturers)
|
|
True
|
|
(Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
|
|
mempty
|
|
|
|
(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)
|
|
<*> lecturerForm
|
|
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))
|
|
`E.LeftOuterJoin`
|
|
(E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
|
|
|
|
-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
|
|
-- forceUserTableType = id
|
|
|
|
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
|
|
-- This ought to ease refactoring the query
|
|
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
|
|
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
|
|
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
|
|
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
|
|
queryUserNote = $(sqlLOJproj 3 2)
|
|
|
|
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
|
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
|
|
|
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
|
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
|
|
|
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
|
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
|
|
|
|
|
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
|
|
, E.SqlExpr (E.Value UTCTime)
|
|
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
|
|
, StudyFeaturesDescription')
|
|
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
|
|
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
|
|
features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
|
|
E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
|
|
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
|
|
|
|
|
|
type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))
|
|
|
|
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
|
|
|
|
_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
|
|
_userTableFeatures = _dbrOutput . _4
|
|
|
|
_rowUserSemester :: Traversal' UserTableData Int
|
|
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
|
|
|
|
|
|
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserComment tid ssh csh =
|
|
sortable (Just "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
|
|
|
|
colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
|
|
foldMap numCell . preview _rowUserSemester
|
|
|
|
colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
|
|
foldMap i18nCell . view (_userTableFeatures . _3)
|
|
|
|
colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
|
|
foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
|
|
|
|
colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
|
|
foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
|
|
|
|
colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
|
|
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
|
|
|
|
makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
|
|
makeCourseUserTable cid colChoices psValidator =
|
|
-- -- psValidator has default sorting and filtering
|
|
let dbtIdent = "courseUsers" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery = userTableQuery cid
|
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
|
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
|
dbtColonnade = colChoices
|
|
dbtSorting = Map.fromList
|
|
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
|
, sortUserSurname queryUser -- needed for initial sorting
|
|
, sortUserDisplayName queryUser -- needed for initial sorting
|
|
, sortUserEmail queryUser
|
|
, sortUserMatriclenr queryUser
|
|
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
|
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
|
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
|
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
|
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
|
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
|
, ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
|
E.sub_select . E.from $ \edit -> do
|
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
|
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
|
)
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameLink queryUser
|
|
, fltrUserEmail queryUser
|
|
, fltrUserMatriclenr queryUser
|
|
, fltrUserNameEmail queryUser
|
|
-- , ("course-user-degree", error "TODO") -- TODO
|
|
-- , ("course-user-field" , error "TODO") -- TODO
|
|
, ("course-user-semesternr", FilterColumn $ mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
|
-- , ("course-registration", error "TODO") -- TODO
|
|
-- , ("course-user-note", error "TODO") -- TODO
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailUI mPrev
|
|
, fltrUserMatriclenrUI mPrev
|
|
]
|
|
dbtParams = def
|
|
in dbTableWidget' psValidator DBTable{..}
|
|
|
|
|
|
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR tid ssh csh = do
|
|
(course, numParticipants, participantTable) <- runDB $ do
|
|
let colChoices = mconcat
|
|
[ colUserNameLink (CourseR tid ssh csh . CUserR)
|
|
, colUserEmail
|
|
, colUserMatriclenr
|
|
, colUserDegreeShort
|
|
, colUserField
|
|
, colUserSemester
|
|
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
|
|
, colUserComment tid ssh csh
|
|
]
|
|
psValidator = def & defaultSortingByName
|
|
Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
numParticipants <- count [CourseParticipantCourse ==. cid]
|
|
participantTable <- makeCourseUserTable cid colChoices psValidator
|
|
return (course, numParticipants, participantTable)
|
|
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
|
|
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
|
|
siteLayout headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "course-participants")
|
|
|
|
|
|
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
|
getCUserR = postCUserR
|
|
postCUserR 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
|
|
let currentRoute = CourseR tid ssh csh (CUserR uCId)
|
|
dozentId <- requireAuthId
|
|
uid <- decrypt uCId
|
|
-- DB reads
|
|
(cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
-- Abfrage Benutzerdaten
|
|
user <- get404 uid
|
|
registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid)
|
|
-- Abfrage Teilnehmernotiz
|
|
let thisUniqueNote = UniqueCourseUserNote uid cid
|
|
mbNoteEnt <- getBy thisUniqueNote
|
|
(noteText,noteEdits) <- case mbNoteEnt of
|
|
Nothing -> return (Nothing,[])
|
|
(Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
|
|
noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
|
|
E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
|
|
E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
|
|
E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
|
|
E.limit 1 -- more will be shown, if changed here
|
|
return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
|
|
return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
|
|
-- Abfrage Studiengänge
|
|
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
|
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
|
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
|
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
|
return (studyfeat, studydegree, studyterms)
|
|
|
|
return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies)
|
|
let editByWgt = [whamlet|
|
|
$forall (etime,_eemail,ename,_esurname) <- noteEdits
|
|
<br>
|
|
_{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
|
|
|] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
|
|
|
|
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
|
|
aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
|
|
<* saveButton
|
|
formResult noteRes $ \mbNote -> (do
|
|
now <- liftIO getCurrentTime
|
|
case mbNote of
|
|
Nothing -> do
|
|
runDB $ do
|
|
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
|
|
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
|
|
deleteBy thisUniqueNote
|
|
addMessageI Info MsgCourseUserNoteDeleted
|
|
redirect currentRoute -- reload page after post
|
|
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes
|
|
(Just note) -> do
|
|
runDB $ do
|
|
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
|
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
|
addMessageI Success MsgCourseUserNoteSaved
|
|
redirect currentRoute -- reload page after post
|
|
)
|
|
-- De-/Register Button for Lecturer
|
|
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
|
((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret
|
|
formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification
|
|
| isJust registration -> do
|
|
runDB $ deleteBy $ UniqueParticipant uid cid
|
|
addMessageI Info MsgCourseDeregisterOk
|
|
| otherwise -> do
|
|
actTime <- liftIO getCurrentTime
|
|
regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId
|
|
when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
|
|
-- generate output
|
|
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
|
|
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
|
|
siteLayout headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "course-user")
|
|
|
|
|
|
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!
|
|
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
|
|
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
|
getCNotesR = error "CNotesR: Not implemented"
|
|
postCNotesR = error "CNotesR: Not implemented"
|