Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Gregor Kleen
commit
d36e9937be
@ -65,8 +65,8 @@ CourseCapacity: Kapazität
|
||||
CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
|
||||
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
|
||||
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
|
||||
CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseRegisterOk: Anmeldung erfolgreich
|
||||
CourseDeregisterOk: Erfolgreich abgemeldet
|
||||
CourseStudyFeature: Assoziiertes Hauptfach
|
||||
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
@ -112,6 +112,9 @@ CourseUserNote: Notiz
|
||||
CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
|
||||
CourseUserNoteSaved: Notizänderungen gespeichert
|
||||
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
|
||||
CourseUserDeregister: Abmelden
|
||||
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
|
||||
|
||||
CourseLecturers: Kursverwalter
|
||||
CourseLecturer: Dozent
|
||||
CourseAssistant: Assistent
|
||||
|
||||
2
routes
2
routes
@ -75,7 +75,7 @@
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET
|
||||
/users CUsersR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
/correctors CHiWisR GET
|
||||
/notes CNotesR GET POST !corrector
|
||||
|
||||
@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
|
||||
, isInfixOf, hasInfix
|
||||
, any, all
|
||||
, SqlIn(..)
|
||||
, mkExactFilter, mkContainsFilter
|
||||
, anyFilter
|
||||
, mkExactFilter, mkExactFilterWith
|
||||
, mkContainsFilter
|
||||
, anyFilter, allFilter
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
|
||||
@ -74,13 +75,22 @@ _queryFeaturesDegree = $(sqlIJproj 3 2)
|
||||
-- Given a lens-like function, make filter for exact matches in a collection
|
||||
-- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
|
||||
mkExactFilter :: (PersistField a)
|
||||
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
|
||||
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
|
||||
-> t -- ^ query row
|
||||
-> Set.Set a -- ^ needle collection
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkExactFilter lenslike row criterias
|
||||
mkExactFilter = mkExactFilterWith id
|
||||
|
||||
-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
|
||||
mkExactFilterWith :: (PersistField b)
|
||||
=> (a -> b) -- ^ type conversion
|
||||
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
|
||||
-> t -- ^ query row
|
||||
-> Set.Set a -- ^ needle collection
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkExactFilterWith cast lenslike row criterias
|
||||
| Set.null criterias = true
|
||||
| otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
|
||||
| otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
|
||||
|
||||
-- | generic filter creation for dbTable
|
||||
-- Given a lens-like function, make filter searching for needles in String-like elements
|
||||
@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias
|
||||
| Set.null criterias = true
|
||||
| otherwise = any (hasInfix $ lenslike row) criterias
|
||||
|
||||
|
||||
anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
||||
-> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
|
||||
-- | Combine several filters, using logical or
|
||||
anyFilter :: (Foldable f)
|
||||
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
||||
-> t
|
||||
-> Set.Set Text
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
anyFilter fltrs needle criterias = F.foldr aux false fltrs
|
||||
where
|
||||
aux fltr acc = fltr needle criterias E.||. acc
|
||||
aux fltr acc = fltr needle criterias E.||. acc
|
||||
|
||||
-- | Combine several filters, using logical and
|
||||
allFilter :: (Foldable f)
|
||||
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
||||
-> t
|
||||
-> Set.Set Text
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
||||
where
|
||||
aux fltr acc = fltr needle criterias E.&&. acc
|
||||
@ -305,7 +305,6 @@ postAdminFeaturesR = do
|
||||
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
|
||||
let newKeys = map (StudyTermsKey' . fst) infAccepted
|
||||
setSessionJson sessionKeyNewStudyTerms newKeys
|
||||
-- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys
|
||||
if | null infAccepted
|
||||
-> addMessageI Info MsgNoCandidatesInferred
|
||||
| otherwise
|
||||
@ -324,7 +323,6 @@ postAdminFeaturesR = do
|
||||
_other -> runDB Candidates.conflicts
|
||||
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
|
||||
-- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys
|
||||
( (degreeResult,degreeTable)
|
||||
, (studyTermsResult,studytermsTable)
|
||||
, ((), candidateTable)) <- runDB $ (,,)
|
||||
|
||||
@ -14,6 +14,7 @@ import Handler.Utils.Delete
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Table.Columns
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -705,7 +706,7 @@ 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) <-
|
||||
[
|
||||
@ -819,57 +820,100 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell
|
||||
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
|
||||
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
|
||||
|
||||
makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
|
||||
makeCourseUserTable cid colChoices psValidator =
|
||||
-- -- psValidator has default sorting and filtering
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery = userTableQuery cid
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
||||
dbtColonnade = colChoices
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
||||
, sortUserSurname queryUser -- needed for initial sorting
|
||||
, sortUserDisplayName queryUser -- needed for initial sorting
|
||||
, sortUserEmail queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.sub_select . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameLink queryUser
|
||||
, fltrUserEmail queryUser
|
||||
, fltrUserMatriclenr queryUser
|
||||
, fltrUserNameEmail queryUser
|
||||
-- , ("course-user-degree", error "TODO") -- TODO
|
||||
-- , ("course-user-field" , error "TODO") -- TODO
|
||||
, ("course-user-semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
]
|
||||
dbtParams = def
|
||||
in dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
data CourseUserAction = CourseUserDeregister
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCUsersR tid ssh csh = do
|
||||
(course, numParticipants, participantTable) <- runDB $ do
|
||||
instance Universe CourseUserAction
|
||||
instance Finite CourseUserAction
|
||||
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''CourseUserAction id
|
||||
|
||||
makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
|
||||
makeCourseUserTable cid colChoices psValidator = do
|
||||
Just currentRoute <- liftHandlerT getCurrentRoute
|
||||
-- -- psValidator has default sorting and filtering
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery = userTableQuery cid
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
||||
dbtColonnade = colChoices
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
||||
, sortUserSurname queryUser -- needed for initial sorting
|
||||
, sortUserDisplayName queryUser -- needed for initial sorting
|
||||
, sortUserEmail queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.sub_select . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameLink queryUser
|
||||
, fltrUserEmail queryUser
|
||||
, fltrUserMatriclenr queryUser
|
||||
, fltrUserNameEmail queryUser
|
||||
, ("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))
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
|
||||
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
|
||||
]
|
||||
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 CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, 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
|
||||
[ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
, colUserEmail
|
||||
, colUserMatriclenr
|
||||
, colUserDegreeShort
|
||||
@ -879,10 +923,18 @@ getCUsersR tid ssh csh = do
|
||||
, colUserComment tid ssh csh
|
||||
]
|
||||
psValidator = def & defaultSortingByName
|
||||
Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
numParticipants <- count [CourseParticipantCourse ==. cid]
|
||||
participantTable <- makeCourseUserTable cid colChoices psValidator
|
||||
return (course, numParticipants, participantTable)
|
||||
table <- makeCourseUserTable cid colChoices psValidator
|
||||
return (ent, numParticipants, table)
|
||||
formResult participantRes $ \case
|
||||
(CourseUserDeregister,selectedUsers) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ CourseParticipantCourse ==. cid
|
||||
, CourseParticipantUser <-. Set.toList selectedUsers
|
||||
]
|
||||
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
|
||||
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
|
||||
siteLayout headingLong $ do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user