a6348f9b9c
Removed DisplayAble typeclass; replaced DisplayAble instances by RenderMessage or ToMessage instances; removed unnecessary tshow calls in de.msg Closes #184
1636 lines
86 KiB
Haskell
1636 lines
86 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.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|_{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|_{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|#{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|_{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|_{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{..} } -> occurrencesCell 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
|
||
|
||
let
|
||
examDBTable = DBTable{..}
|
||
where
|
||
dbtSQLQuery exam = do
|
||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||
return exam
|
||
dbtRowKey = (E.^. ExamId)
|
||
dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
|
||
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
||
return r
|
||
dbtColonnade = dbColonnade $ mconcat
|
||
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName)
|
||
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
|
||
startT <- formatTime SelFormatDateTime examStart
|
||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||
[whamlet|
|
||
$newline never
|
||
#{startT}
|
||
$maybe endT' <- endT
|
||
\ – #{endT'}
|
||
|]
|
||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
||
isRegistered <- case mbAid of
|
||
Nothing -> return False
|
||
Just uid -> existsBy $ UniqueExamRegistration eId uid
|
||
if
|
||
| mayRegister -> do
|
||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||
return $ wrapForm examRegisterForm def
|
||
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
||
, formEncoding = examRegisterEnctype
|
||
, formSubmit = FormNoSubmit
|
||
}
|
||
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||
| otherwise -> return mempty
|
||
]
|
||
dbtSorting = Map.fromList
|
||
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
||
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
|
||
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
|
||
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
|
||
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
|
||
]
|
||
dbtFilter = Map.empty
|
||
dbtFilterUI = const mempty
|
||
dbtStyle = def
|
||
dbtParams = def
|
||
dbtIdent :: Text
|
||
dbtIdent = "exams"
|
||
|
||
examDBTableValidator = def
|
||
& defaultSorting [SortAscBy "time"]
|
||
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
|
||
|
||
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} #{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} #{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 & setTooltip MsgMultiEmailFieldTip) 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
|