1580 lines
84 KiB
Haskell
1580 lines
84 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.Tutorial
|
|
import Handler.Utils.Communication
|
|
import Handler.Utils.Form.MassInput
|
|
import Handler.Utils.Delete
|
|
import Handler.Utils.Database
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.Table.Columns
|
|
import Handler.Utils.Invitations
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
-- import Data.Time
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Data.Function ((&))
|
|
-- import Yesod.Form.Bootstrap3
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
import Jobs.Queue
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
|
import Control.Monad.Except (MonadError(..))
|
|
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
|
|
-- 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 textField (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)) ->
|
|
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
|
|
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- 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
|
|
staff <- 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 ( lecturer E.^. LecturerType
|
|
, user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
|
let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
|
|
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
|
|
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
|
|
(assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff
|
|
correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
|
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
|
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors)
|
|
|
|
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
|
|
|
|
let
|
|
tutorialDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery tutorial = do
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
return tutorial
|
|
dbtRowKey = (E.^. TutorialId)
|
|
dbtProj = return
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
|
|
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
|
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
|
|
tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
|
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
|
return [whamlet|
|
|
$newline never
|
|
<ul .list--iconless .list--inline .list--comma-separated>
|
|
$forall tutor <- tutTutors
|
|
<li>
|
|
^{nameEmailWidget' tutor}
|
|
|]
|
|
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
|
|
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime
|
|
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
|
|
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
|
|
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
|
|
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
|
|
Nothing -> mempty
|
|
Just tutorialCapacity' -> sqlCell $ do
|
|
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
|
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
|
in return $ E.val tutorialCapacity' E.-. numParticipants
|
|
return . toWidget . tshow $ max 0 freeCapacity
|
|
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
|
isRegistered <- case mbAid of
|
|
Nothing -> return False
|
|
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
|
|
if
|
|
| mayRegister -> do
|
|
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
|
return $ wrapForm tutRegisterForm def
|
|
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
|
|
, formEncoding = tutRegisterEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
| isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
|
|
| otherwise -> return mempty
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
|
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
|
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
|
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
|
|
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
|
|
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
|
|
]
|
|
dbtFilter = Map.empty
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "tutorials"
|
|
|
|
tutorialDBTableValidator = def
|
|
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
|
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
|
|
|
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 False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
|
|
_other -> mreq (studyFeaturesPrimaryFieldFor False [ ] 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
|
|
|
|
|
|
-- | Workaround for klicking register button without being logged in.
|
|
-- After log in, the user sees a "get request not supported" error.
|
|
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCRegisterR tid ssh csh = do
|
|
muid <- maybeAuthId
|
|
case muid of
|
|
Nothing -> addMessageI Info MsgLoginNecessary
|
|
(Just uid) -> runDB $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
registration <- getBy (UniqueParticipant uid cid)
|
|
when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
|
|
redirect $ CourseR tid ssh csh CShowR
|
|
|
|
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 courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
|
|
getParams = concat
|
|
[ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
|
|
, [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
|
|
, [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
|
|
]
|
|
|
|
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 (\p -> Just . SomeRoute $ CourseNewR :#: p) 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
|
|
courseData <- runDB $ do
|
|
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
|
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
|
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
|
|
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
|
|
-- 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 (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
|
|
|
|
|
|
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 :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
|
|
courseEditHandler miButtonAction mbCourseForm = do
|
|
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
|
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
|
|
formResult result $ \case
|
|
res@CourseForm
|
|
{ cfCourseId = Nothing
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
} -> do -- create new course
|
|
now <- liftIO getCurrentTime
|
|
insertOkay <- runDBJobs $ 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
|
|
let (invites, adds) = partitionEithers $ cfLecturers res
|
|
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
|
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
|
insert_ $ CourseEdit aid now cid
|
|
return insertOkay
|
|
case insertOkay of
|
|
Just _ -> do
|
|
-- addMessageI Info $ MsgCourseNewOk tid ssh csh
|
|
redirect $ CourseR tid ssh csh CShowR
|
|
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 <- runDBJobs $ 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]
|
|
deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
|
|
let (invites, adds) = partitionEithers $ cfLecturers res
|
|
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
|
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
|
|
|
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
|
|
}
|
|
|
|
|
|
instance IsInvitableJunction Lecturer where
|
|
type InvitationFor Lecturer = Course
|
|
data InvitableJunction Lecturer = JunctionLecturer
|
|
{ jLecturerType :: LecturerType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData Lecturer = InvDBDataLecturer
|
|
{ invDBLecturerType :: Maybe LecturerType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData Lecturer = InvTokenDataLecturer
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
|
|
(\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
|
|
|
|
instance ToJSON (InvitableJunction Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
lecturerInvitationConfig :: InvitationConfig Lecturer
|
|
lecturerInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
|
invitationResolveFor = do
|
|
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
|
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
|
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
|
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
|
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- liftHandlerT requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
|
|
Nothing -> areq (selectField optionsFinite) lFs Nothing
|
|
Just lType -> aforced (selectField optionsFinite) lFs lType
|
|
where
|
|
toJunction jLecturerType = JunctionLecturer{..}
|
|
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
|
|
invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
|
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
|
|
|
|
|
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 :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
|
}
|
|
|
|
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
|
|
courseToForm (Entity cid Course{..}) lecs lecInvites = 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 = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
|
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
|
|
}
|
|
|
|
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
|
makeCourseForm miButtonAction 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 (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail 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 (CI.mk -> email, mLid) ->
|
|
let new = maybe (Left email) Right mLid
|
|
in FormSuccess $ \prev -> if
|
|
| new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
|
|
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
|
|
FormFailure errs -> FormFailure errs
|
|
FormMissing -> FormMissing
|
|
addView' = $(widgetFile "course/lecturerMassInput/add")
|
|
return (addRes'', addView')
|
|
|
|
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
|
|
miCell _ (Right lid) defType nudge = \csrf -> do
|
|
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
|
|
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
|
|
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
|
|
return (Just <$> lrwRes,lrwView')
|
|
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
|
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
|
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
|
return (lrwRes,lrwView')
|
|
|
|
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
|
-> ListPosition -- ^ Coordinate to delete
|
|
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
|
miDelete = miDeleteList
|
|
|
|
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
|
miAllowAdd _ _ _ = True
|
|
|
|
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miLayout :: ListLength
|
|
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
|
|
-> Map ListPosition Widget -- ^ Cell widgets
|
|
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
|
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
|
-> Widget
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
|
|
|
|
miIdent :: Text
|
|
miIdent = "lecturers"
|
|
|
|
|
|
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
|
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
|
|
MassInput{..}
|
|
(fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
|
|
True
|
|
(Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
|
|
mempty
|
|
where
|
|
liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
|
|
liftEither (Right lid , Just lType) = Right (lid , lType )
|
|
liftEither (Left lEmail, mLType ) = Left (lEmail, mLType)
|
|
liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to"
|
|
|
|
unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
|
|
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
|
|
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
|
|
|
|
(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
|
|
errorMsgs' <- traverse validateCourse result
|
|
return $ case errorMsgs' of
|
|
FormSuccess errorMsgs
|
|
| 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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
|
|
validateCourse CourseForm{..} = do
|
|
uid <- liftHandlerT requireAuthId
|
|
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
return
|
|
[ mr msg | (False, msg) <-
|
|
[
|
|
( NTop cfRegFrom <= NTop cfRegTo
|
|
, MsgCourseRegistrationEndMustBeAfterStart
|
|
)
|
|
,
|
|
( NTop cfRegFrom <= NTop cfDeRegUntil
|
|
, MsgCourseDeregistrationEndMustBeAfterStart
|
|
)
|
|
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
|
|
, MsgCourseUserMustBeLecturer
|
|
)
|
|
] ]
|
|
|
|
|
|
|
|
--------------------
|
|
-- 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 $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
|
|
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
|
|
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)
|
|
|
|
|
|
data CourseUserAction = CourseUserSendMail | CourseUserDeregister
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe CourseUserAction
|
|
instance Finite CourseUserAction
|
|
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''CourseUserAction id
|
|
|
|
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe TutorialUserAction
|
|
instance Finite TutorialUserAction
|
|
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
|
|
|
makeCourseUserTable :: forall h act.
|
|
( Functor h, ToSortable h
|
|
, RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
|
|
=> CourseId
|
|
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
|
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
|
|
-> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
|
|
-> DB (FormResult (act, Set UserId), Widget)
|
|
makeCourseUserTable cid restrict colChoices psValidator = do
|
|
Just currentRoute <- liftHandlerT getCurrentRoute
|
|
-- -- psValidator has default sorting and filtering
|
|
let dbtIdent = "courseUsers" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
|
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
|
|
, ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
|
, ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
|
, ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
|
, ("field" , FilterColumn $ E.anyFilter
|
|
[ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)
|
|
, E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
|
|
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
|
] )
|
|
, ("degree" , FilterColumn $ E.anyFilter
|
|
[ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
|
|
, E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
|
|
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
|
] )
|
|
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
|
, ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
|
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
|
)
|
|
-- , ("course-registration", error "TODO") -- TODO
|
|
-- , ("course-user-note", error "TODO") -- TODO
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ fltrUserNameEmailUI mPrev
|
|
, fltrUserMatriclenrUI mPrev
|
|
, prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
|
|
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
|
|
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \csrf -> do
|
|
(res,vw) <- mreq (selectField optionsFinite) "" Nothing
|
|
let formWgt = toWidget csrf <> fvInput vw
|
|
formRes = (, mempty) . First . Just <$> res
|
|
return (formRes,formWgt)
|
|
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
where
|
|
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
|
|
postprocess inp = do
|
|
(First (Just act), usrMap) <- inp
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
return (act, usrSet)
|
|
|
|
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR = postCUsersR
|
|
postCUsersR tid ssh csh = do
|
|
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
|
|
let colChoices = mconcat
|
|
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, colUserNameLink (CourseR tid ssh csh . CUserR)
|
|
, colUserEmail
|
|
, colUserMatriclenr
|
|
, colUserDegreeShort
|
|
, colUserField
|
|
, colUserSemester
|
|
, sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
|
|
, colUserComment tid ssh csh
|
|
]
|
|
psValidator = def & defaultSortingByName
|
|
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
numParticipants <- count [CourseParticipantCourse ==. cid]
|
|
table <- makeCourseUserTable cid (const E.true) colChoices psValidator
|
|
return (ent, numParticipants, table)
|
|
formResult participantRes $ \case
|
|
(CourseUserSendMail, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(CourseUserDeregister,selectedUsers) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ CourseParticipantCourse ==. cid
|
|
, CourseParticipantUser <-. Set.toList selectedUsers
|
|
]
|
|
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
|
|
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
|
|
siteLayout headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "course-participants")
|
|
|
|
|
|
|
|
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
|
getTUsersR = postTUsersR
|
|
postTUsersR tid ssh csh tutn = do
|
|
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
|
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
|
let colChoices = mconcat
|
|
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, colUserName
|
|
, colUserEmail
|
|
, colUserMatriclenr
|
|
, colUserDegreeShort
|
|
, colUserField
|
|
, colUserSemester
|
|
]
|
|
psValidator = def
|
|
& defaultSortingByName
|
|
& restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
|
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
table <- makeCourseUserTable cid isInTut colChoices psValidator
|
|
return (tut, table)
|
|
|
|
formResult participantRes $ \case
|
|
(TutorialUserSendMail, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(TutorialUserDeregister,selectedUsers) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ TutorialParticipantTutorial ==. tutid
|
|
, TutorialParticipantUser <-. Set.toList selectedUsers
|
|
]
|
|
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
|
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
$(widgetFile "tutorial-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{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
-- Abfrage Benutzerdaten
|
|
user <- get404 uid
|
|
registration <- 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)
|
|
let noteFrag :: Text
|
|
noteFrag = "notes"
|
|
noteWidget = wrapForm noteView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
|
|
, formEncoding = noteEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just noteFrag
|
|
}
|
|
formResult noteRes $ \mbNote -> do
|
|
now <- liftIO getCurrentTime
|
|
runDB $ case mbNote of
|
|
Nothing -> 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
|
|
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
|
|
(Just note) -> do
|
|
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
|
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
|
addMessageI Success MsgCourseUserNoteSaved
|
|
redirect $ currentRoute :#: noteFrag -- reload page after post
|
|
|
|
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
|
|
let currentField :: Maybe (Maybe StudyFeaturesId)
|
|
currentField = courseParticipantField . entityVal <$> mRegistration
|
|
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
|
|
|
let registrationFieldFrag :: Text
|
|
registrationFieldFrag = "registration-field"
|
|
regFieldWidget = wrapForm regFieldView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
|
|
, formEncoding = regFieldEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormAutoSubmit
|
|
, formAnchor = Just registrationFieldFrag
|
|
}
|
|
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
|
|
formResult regFieldRes $ \courseParticipantField' -> do
|
|
runDB $ do
|
|
update pId [ CourseParticipantField =. courseParticipantField' ]
|
|
addMessageI Success MsgCourseStudyFeatureUpdated
|
|
redirect $ currentRoute :#: registrationFieldFrag
|
|
|
|
let regButton
|
|
| Just _ <- mRegistration = BtnDeregister
|
|
| otherwise = BtnRegister
|
|
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
|
|
|
|
let registrationButtonFrag :: Text
|
|
registrationButtonFrag = "registration-button"
|
|
regButtonWidget = wrapForm regButtonView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
|
, formEncoding = regButtonEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just registrationButtonFrag
|
|
}
|
|
formResult regButtonRes $ \case
|
|
BtnDeregister
|
|
| Just (Entity pId _) <- mRegistration
|
|
-> do
|
|
runDB $ delete pId
|
|
addMessageI Info MsgCourseDeregisterOk
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
| otherwise
|
|
-> invalidArgs ["User not registered"]
|
|
BtnRegister -> do
|
|
now <- liftIO getCurrentTime
|
|
let primaryField
|
|
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
|
|
= Just featId
|
|
| otherwise
|
|
= Nothing
|
|
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
|
|
case pId of
|
|
Just _ -> do
|
|
addMessageI Success MsgCourseRegisterOk
|
|
redirect currentRoute
|
|
Nothing -> invalidArgs ["User already registered"]
|
|
|
|
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
|
|
|
-- 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 = postCNotesR
|
|
postCNotesR _ _ _ = do
|
|
defaultLayout $ [whamlet|You have corrector access to this course.|]
|
|
|
|
|
|
getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCCommR = postCCommR
|
|
postCCommR tid ssh csh = do
|
|
jSender <- requireAuthId
|
|
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
|
|
commR CommunicationRoute
|
|
{ crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
|
|
, crUltDest = SomeRoute $ CourseR tid ssh csh CCommR
|
|
, crJobs = \Communication{..} -> do
|
|
let jSubject = cSubject
|
|
jMailContent = cBody
|
|
jCourse = cid
|
|
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
|
jMailObjectUUID <- liftIO getRandom
|
|
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
|
Left email -> return . Address Nothing $ CI.original email
|
|
Right rid -> userAddress <$> getJust rid
|
|
forM_ allRecipients $ \jRecipientEmail ->
|
|
yield JobSendCourseCommunication{..}
|
|
, crRecipients = Map.fromList
|
|
[ ( RGCourseParticipants
|
|
, E.from $ \(user `E.InnerJoin` participant) -> do
|
|
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
return user
|
|
)
|
|
, ( RGCourseLecturers
|
|
, E.from $ \(user `E.InnerJoin` lecturer) -> do
|
|
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
|
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
|
return user
|
|
)
|
|
, ( RGCourseCorrectors
|
|
, E.from $ \user -> do
|
|
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
|
|
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
|
|
return user
|
|
)
|
|
, ( RGCourseTutors
|
|
, E.from $ \user -> do
|
|
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
|
|
return user
|
|
)
|
|
]
|
|
, crRecipientAuth = Just $ \uid -> do
|
|
cID <- encrypt uid
|
|
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
|
}
|
|
|
|
|
|
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCLecInviteR = postCLecInviteR
|
|
postCLecInviteR = invitationR lecturerInvitationConfig
|
|
|
|
|
|
|
|
-- Invitations for ordinary participants of this course
|
|
instance IsInvitableJunction CourseParticipant where
|
|
type InvitationFor CourseParticipant = Course
|
|
data InvitableJunction CourseParticipant = JunctionParticipant
|
|
{ jParticipantRegistration :: UTCTime
|
|
, jParticipantFild :: Maybe StudyFeaturesId
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
|
-- no data needed in DB to manage participant invitation
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
|
|
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
|
|
|
|
ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ()))
|
|
|
|
instance ToJSON (InvitableJunction CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
participantInvitationConfig :: InvitationConfig CourseParticipant
|
|
participantInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
|
invitationResolveFor = do
|
|
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
|
|
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
|
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
|
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
|
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
|
-- Keine besonderen Einschränkungen beim Einlösen der Token
|
|
-- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden!
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- liftHandlerT requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
|
|
now <- liftIO getCurrentTime
|
|
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
|
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
|
return $ JunctionParticipant <$> pure now <*> studyFeatures
|
|
invitationSuccessMsg Course{..} _ =
|
|
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
|
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
|
|
|
data AddRecipientsResult = AddRecipientsResult
|
|
{ aurAlreadyRegistered
|
|
, aurNoUniquePrimaryField
|
|
, aurSuccess :: [UserEmail]
|
|
} deriving (Read, Show, Generic, Typeable)
|
|
|
|
instance Monoid AddRecipientsResult where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCAddUserR = postCAddUserR
|
|
postCAddUserR tid ssh csh = do
|
|
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
|
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
|
|
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
|
(fslI MsgCourseParticipantInviteField) Nothing
|
|
|
|
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
|
|
|
|
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
wrapForm formWgt def
|
|
{ formEncoding
|
|
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
|
}
|
|
where
|
|
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
|
|
processUsers cid users = do
|
|
let (emails,uids) = partitionEithers $ Set.toList users
|
|
AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do
|
|
-- send Invitation eMails to unkown users
|
|
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
|
-- register known users
|
|
execWriterT $ mapM (registerUser cid) uids
|
|
|
|
when (not $ null emails) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
|
|
|
when (not $ null alreadyRegistered) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
|
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
|
|
|
when (not $ null registeredNoField) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
|
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
|
|
|
when (not $ null registeredOneField) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField
|
|
|
|
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
|
registerUser cid uid = exceptT tell tell $ do
|
|
User{..} <- lift . lift $ getJust uid
|
|
|
|
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
|
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
|
|
|
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
|
|
|
let courseParticipantField
|
|
| [f] <- features = Just f
|
|
| otherwise = Nothing
|
|
|
|
courseParticipantRegistration <- liftIO getCurrentTime
|
|
void . lift . lift . insert $ CourseParticipant
|
|
{ courseParticipantCourse = cid
|
|
, courseParticipantUser = uid
|
|
, ..
|
|
}
|
|
|
|
return $ case courseParticipantField of
|
|
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
|
Just _ -> mempty { aurSuccess = pure userEmail }
|
|
|
|
|
|
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCInviteR = postCInviteR
|
|
postCInviteR = invitationR participantInvitationConfig
|