504 lines
27 KiB
Haskell
504 lines
27 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Course.Users
|
|
( queryUser
|
|
, makeCourseUserTable
|
|
, postCUsersR, getCUsersR
|
|
, colUserDegreeShort, colUserField, colUserSemester, colUserSex'
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Handler.Course.Register (deregisterParticipant)
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Vector as Vector
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
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)
|
|
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
|
)
|
|
|
|
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
|
|
|
|
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
|
_userTutorials = _dbrOutput . _5
|
|
|
|
|
|
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) (hasComment True)
|
|
where
|
|
courseLink = CourseR tid ssh csh . CUserR
|
|
|
|
colUserTutorials :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUserTutorials)
|
|
$ \(view _userTutorials -> tuts') ->
|
|
let tuts = sortOn (tutorialName . entityVal) $ (tuts' ^. _1) ++ (tuts' ^.. _2 . folded . _Just)
|
|
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell tuts $ anchorCell'
|
|
(\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
|
|
(tutorialName . entityVal)
|
|
|
|
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)
|
|
|
|
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserSex' = colUserSex $ hasUser . _userSex
|
|
|
|
|
|
data UserTableCsvStudyFeature = UserTableCsvStudyFeature
|
|
{ csvUserField :: Text
|
|
, csvUserDegree :: Text
|
|
, csvUserSemester :: Int
|
|
, csvUserType :: StudyFieldType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
makeLenses_ ''UserTableCsvStudyFeature
|
|
|
|
data UserTableCsv = UserTableCsv
|
|
{ csvUserName :: Text
|
|
, csvUserSex :: Maybe Sex
|
|
, csvUserMatriculation :: Maybe Text
|
|
, csvUserEmail :: CI Email
|
|
, csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
|
|
, csvUserRegistration :: UTCTime
|
|
, csvUserNote :: Maybe Html
|
|
, csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
makeLenses_ ''UserTableCsv
|
|
|
|
instance Csv.ToNamedRecord UserTableCsv where
|
|
toNamedRecord UserTableCsv{..} = Csv.namedRecord $
|
|
[ "name" Csv..= csvUserName
|
|
, "sex" Csv..= csvUserSex
|
|
, "matriculation" Csv..= csvUserMatriculation
|
|
, "email" Csv..= csvUserEmail
|
|
] ++ case csvUserStudyFeatures of
|
|
Left feats
|
|
-> [ "field" Csv..= (csvUserField <$> feats)
|
|
, "degree" Csv..= (csvUserDegree <$> feats)
|
|
, "semester" Csv..= (csvUserSemester <$> feats)
|
|
]
|
|
Right feats
|
|
-> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..}
|
|
-> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
|
|
in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
|
|
in [ "study-features" Csv..= featsStr
|
|
]
|
|
++
|
|
[ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
|
|
in "tutorial" Csv..= tutsStr
|
|
] ++
|
|
[ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
|
|
| (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
|
|
] ++
|
|
[ "registration" Csv..= csvUserRegistration
|
|
, "note" Csv..= csvUserNote
|
|
]
|
|
instance CsvColumnsExplained UserTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single "name" MsgCsvColumnUserName
|
|
, single "sex" MsgCsvColumnUserSex
|
|
, single "matriculation" MsgCsvColumnUserMatriculation
|
|
, single "email" MsgCsvColumnUserEmail
|
|
, single "study-features" MsgCsvColumnUserStudyFeatures
|
|
, single "field" MsgCsvColumnUserField
|
|
, single "degree" MsgCsvColumnUserDegree
|
|
, single "semester" MsgCsvColumnUserSemester
|
|
, single "tutorial" MsgCsvColumnUserTutorial
|
|
, single "registration" MsgCsvColumnUserRegistration
|
|
, single "note" MsgCsvColumnUserNote
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
newtype UserCsvExportData = UserCsvExportData
|
|
{ csvUserSimplifiedFeaturesOfStudy :: Bool
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
instance Default UserCsvExportData where
|
|
def = UserCsvExportData True
|
|
|
|
userTableCsvHeader :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header
|
|
userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
|
|
[ "name" ] ++
|
|
[ "sex" | showSex ] ++
|
|
[ "matriculation", "email"
|
|
] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
|
|
[ "tutorial" | hasEmptyRegGroup ] ++
|
|
map (encodeUtf8 . CI.foldedCase) regGroups ++
|
|
[ "registration", "note"
|
|
]
|
|
where
|
|
hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
|
|
regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts
|
|
|
|
|
|
data CourseUserAction = CourseUserSendMail
|
|
| CourseUserDeregister
|
|
| CourseUserRegisterTutorial
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe CourseUserAction
|
|
instance Finite CourseUserAction
|
|
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''CourseUserAction id
|
|
|
|
data CourseUserActionData = CourseUserSendMailData
|
|
| CourseUserDeregisterData
|
|
{ deregisterReason :: Maybe Text
|
|
}
|
|
| CourseUserRegisterTutorialData
|
|
{ registerTutorial :: TutorialId
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
makeCourseUserTable :: forall h act act'.
|
|
( Functor h, ToSortable h
|
|
, Ord act, PathPiece act, RenderMessage UniWorX act
|
|
)
|
|
=> CourseId
|
|
-> Map act (AForm Handler act')
|
|
-> (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))
|
|
-> Maybe (Csv.Name -> Bool)
|
|
-> DB (FormResult (act', Set UserId), Widget)
|
|
makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|
currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
|
|
Course{..} <- getJust cid
|
|
csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
|
|
tutorials <- selectList [ TutorialCourse ==. cid ] []
|
|
-- -- psValidator has default sorting and filtering
|
|
showSex <- getShowSex
|
|
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)) -> do
|
|
tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
|
|
let
|
|
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
|
|
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
|
|
tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
|
|
return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts)
|
|
dbtColonnade = colChoices
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
|
, single $ sortUserSurname queryUser -- needed for initial sorting
|
|
, single $ sortUserDisplayName queryUser -- needed for initial sorting
|
|
, single $ sortUserEmail queryUser
|
|
, single $ sortUserMatriclenr queryUser
|
|
, sortUserSex (to queryUser . to (E.^. UserSex))
|
|
, single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
|
, single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
|
, single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
|
, single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
|
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
|
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
|
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
|
E.subSelectMaybe . E.from $ \edit -> do
|
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
|
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
|
)
|
|
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
|
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
|
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
|
return . E.min_ $ tutorial E.^. TutorialName
|
|
)
|
|
]
|
|
where single = uncurry Map.singleton
|
|
dbtFilter = mconcat
|
|
[ single $ fltrUserNameLink queryUser
|
|
, single $ fltrUserEmail queryUser
|
|
, single $ fltrUserMatriclenr queryUser
|
|
, single $ fltrUserNameEmail queryUser
|
|
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
|
, single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
|
, single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
|
, single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
|
, single $ ("field" , FilterColumn $ E.anyFilter
|
|
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
|
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
|
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
|
] )
|
|
, single $ ("degree" , FilterColumn $ E.anyFilter
|
|
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
|
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
|
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
|
] )
|
|
, single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
|
, single $ ("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) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
|
)
|
|
-- , ("course-registration", error "TODO") -- TODO
|
|
-- , ("course-user-note", error "TODO") -- TODO
|
|
]
|
|
where single = uncurry Map.singleton
|
|
dbtFilterUI mPrev = mconcat $
|
|
[ fltrUserNameEmailUI mPrev
|
|
, fltrUserMatriclenrUI mPrev
|
|
] ++
|
|
[ fltrUserSexUI mPrev | showSex ] ++
|
|
[ 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
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtCsvEncode = do
|
|
csvColumns' <- csvColumns
|
|
return $ DBTCsvEncode
|
|
{ dbtCsvExportForm = UserCsvExportData
|
|
<$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
|
|
, dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
|
|
UserTableCsv
|
|
<$> view (hasUser . _userDisplayName)
|
|
<*> view (hasUser . _userSex)
|
|
<*> view (hasUser . _userMatrikelnummer)
|
|
<*> view (hasUser . _userEmail)
|
|
<*> if
|
|
| csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
|
|
UserTableCsvStudyFeature
|
|
<$> MaybeT (preview $ _userTableFeatures . _3 . _Just . _studyTermsName . _Just
|
|
<> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
|
|
)
|
|
<*> MaybeT (preview $ _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
|
|
<> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
|
|
)
|
|
<*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester)
|
|
<*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType)
|
|
| otherwise -> Right <$> do
|
|
feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField
|
|
let registered = E.exists . E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
E.&&. participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId)
|
|
E.where_ $ registered
|
|
E.||. feat E.^. StudyFeaturesValid
|
|
E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, feat)
|
|
return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) ->
|
|
UserTableCsvStudyFeature
|
|
{ csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, csvUserSemester = studyFeaturesSemester
|
|
, csvUserType = studyFeaturesType
|
|
}
|
|
<*> view _userTableRegistration
|
|
<*> userNote
|
|
<*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
|
|
, dbtCsvName = unpack csvName
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def
|
|
}
|
|
where
|
|
userNote = runMaybeT $ do
|
|
noteId <- MaybeT . preview $ _userTableNote . _Just
|
|
CourseUserNote{..} <- lift . lift $ getJust noteId
|
|
return courseUserNoteNote
|
|
dbtCsvDecode = Nothing
|
|
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)
|
|
|
|
courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
|
|
courseUserDeregisterForm cid = wFormToAForm $ do
|
|
allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
|
|
if | allocated -> do
|
|
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
|
|
fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
|
|
| otherwise -> pure . pure $ CourseUserDeregisterData Nothing
|
|
|
|
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR = postCUsersR
|
|
postCUsersR tid ssh csh = do
|
|
showSex <- getShowSex
|
|
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
|
|
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
|
|
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
hasTutorials <- exists [TutorialCourse ==. cid]
|
|
let colChoices = mconcat $ catMaybes
|
|
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
|
, guardOn showSex $ colUserSex'
|
|
, pure $ colUserEmail
|
|
, pure $ colUserMatriclenr
|
|
, pure $ colUserDegreeShort
|
|
, pure $ colUserField
|
|
, pure $ colUserSemester
|
|
, guardOn hasTutorials $ colUserTutorials tid ssh csh
|
|
, pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
|
|
, pure $ colUserComment tid ssh csh
|
|
]
|
|
psValidator = def & defaultSortingByName
|
|
acts = mconcat
|
|
[ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
|
|
, singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
|
|
apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
|
|
(fslI MsgCourseTutorial)
|
|
Nothing
|
|
, if
|
|
| mayRegister
|
|
-> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
|
|
| otherwise
|
|
-> mempty
|
|
]
|
|
numParticipants <- count [CourseParticipantCourse ==. cid]
|
|
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
|
|
return (ent, numParticipants, table)
|
|
formResult participantRes $ \case
|
|
(CourseUserSendMailData, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(CourseUserDeregisterData{..}, selectedUsers) -> do
|
|
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
|
|
now <- liftIO getCurrentTime
|
|
Entity _ CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
|
|
lift $ deregisterParticipant courseParticipantUser courseParticipantCourse
|
|
case deregisterReason of
|
|
Just reason
|
|
| is _Just courseParticipantAllocated ->
|
|
lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
|
|
_other -> return ()
|
|
return 1
|
|
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserRegisterTutorialData{..}, selectedUsers) -> do
|
|
runDB . forM_ selectedUsers $
|
|
void . insertUnique . TutorialParticipant registerTutorial
|
|
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
|
|
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")
|