feat(user-schools): automatically assign users to schools
Based on StudyTerms and SchoolLdap
This commit is contained in:
Gregor Kleen
parent
76f8da52e0
commit
12067de2ff
@ -24,7 +24,7 @@ export class HtmlHelpers {
|
||||
}
|
||||
|
||||
_prefixIds(element, idPrefix) {
|
||||
const idAttrs = ['id', 'for', 'data-conditional-input', 'data-modal-trigger'];
|
||||
const idAttrs = ['id', 'for', 'list', 'data-conditional-input', 'data-modal-trigger'];
|
||||
|
||||
idAttrs.forEach((attr) => {
|
||||
Array.from(element.querySelectorAll('[' + attr + ']')).forEach((input) => {
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
import { Utility } from '../../core/utility';
|
||||
import './mass-input.scss';
|
||||
|
||||
const MASS_INPUT_CELL_SELECTOR = '.massinput__cell';
|
||||
const MASS_INPUT_ADD_CELL_SELECTOR = '.massinput__cell--add';
|
||||
|
||||
18
frontend/src/utils/mass-input/mass-input.scss
Normal file
18
frontend/src/utils/mass-input/mass-input.scss
Normal file
@ -0,0 +1,18 @@
|
||||
.massinput-list__wrapper, .massinput-list__cell {
|
||||
display: grid;
|
||||
grid: auto / auto 50px;
|
||||
max-width: 600px;
|
||||
grid-gap: 7px;
|
||||
}
|
||||
|
||||
.massinput-list__field {
|
||||
grid-column: 1;
|
||||
}
|
||||
|
||||
.massinput-list__add, .massinput-list__delete {
|
||||
grid-column: 2;
|
||||
}
|
||||
|
||||
.massinput-list__cell {
|
||||
grid-column: 1 / 3;
|
||||
}
|
||||
@ -581,7 +581,7 @@ RatingFilesUpdated: Korrigierte Dateien überschrieben
|
||||
RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
|
||||
RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
|
||||
RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
|
||||
RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
|
||||
RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
|
||||
RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
|
||||
RatingNegative: Bewertungspunkte dürfen nicht negativ sein
|
||||
RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
|
||||
@ -663,7 +663,8 @@ CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermi
|
||||
CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
|
||||
CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
|
||||
CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
|
||||
CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr}
|
||||
CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Campus-Logins keine Studiengänge ermitteln
|
||||
CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Campus-Logins keine Institute ermitteln
|
||||
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
@ -1572,6 +1573,8 @@ UserMatriculation: Matrikelnummer
|
||||
|
||||
SchoolShort: Kürzel
|
||||
SchoolName: Name
|
||||
SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
|
||||
SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
|
||||
|
||||
SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
|
||||
SchoolTitle ssh@SchoolId: Institut „#{ssh}“
|
||||
|
||||
@ -8,6 +8,9 @@ School json
|
||||
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
|
||||
deriving Ord Eq Show Generic
|
||||
SchoolLdap
|
||||
school SchoolId
|
||||
school SchoolId Maybe
|
||||
orgUnit (CI Text)
|
||||
UniqueOrgUnit orgUnit
|
||||
UniqueOrgUnit orgUnit
|
||||
SchoolTerms
|
||||
school SchoolId
|
||||
terms StudyTermsId
|
||||
@ -42,6 +42,7 @@ UserExamOffice
|
||||
UserSchool -- Managed by users themselves, encodes "schools of interest"
|
||||
user UserId
|
||||
school SchoolId
|
||||
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
|
||||
UniqueUserSchool user school
|
||||
StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
|
||||
user UserId
|
||||
|
||||
2
routes
2
routes
@ -81,7 +81,7 @@
|
||||
/school SchoolListR GET
|
||||
!/school/new SchoolNewR GET POST
|
||||
/school/#SchoolId SchoolR:
|
||||
/ SchoolShowR GET POST
|
||||
/ SchoolEditR GET POST
|
||||
|
||||
/allocation/ AllocationListR GET !free
|
||||
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
||||
|
||||
@ -7,6 +7,7 @@ module Auth.LDAP
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
||||
, ldapUserSchoolAssociation
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -58,16 +59,17 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserEmail = Ldap.Attr "mail"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
||||
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserEmail = Ldap.Attr "mail"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
|
||||
@ -64,6 +64,8 @@ false = E.val False
|
||||
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
|
||||
isJust = E.not_ . E.isNothing
|
||||
|
||||
infix 4 `isInfixOf`, `hasInfix`
|
||||
|
||||
-- | Check if the first string is contained in the text derived from the second argument
|
||||
isInfixOf :: ( E.Esqueleto query expr backend
|
||||
, E.SqlString s1
|
||||
|
||||
@ -65,6 +65,7 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
||||
import qualified Control.Monad.Catch as C
|
||||
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.SchoolLdap
|
||||
import Utils.Form
|
||||
import Utils.Sheet
|
||||
import Utils.SystemMessage
|
||||
@ -152,6 +153,7 @@ deriving instance Generic TutorialR
|
||||
deriving instance Generic ExamR
|
||||
deriving instance Generic CourseApplicationR
|
||||
deriving instance Generic AllocationR
|
||||
deriving instance Generic SchoolR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
@ -1733,7 +1735,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb AdminErrMsgR = return ("Test" , Just AdminR)
|
||||
|
||||
breadcrumb SchoolListR = return ("Institute" , Just AdminR)
|
||||
breadcrumb (SchoolR ssh SchoolShowR) = return (original (unSchoolKey ssh), Just SchoolListR)
|
||||
breadcrumb (SchoolR ssh SchoolEditR) = return (original (unSchoolKey ssh), Just SchoolListR)
|
||||
breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR)
|
||||
|
||||
breadcrumb InfoR = return ("Information" , Nothing)
|
||||
@ -3029,7 +3031,8 @@ data CampusUserConversionException
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidFeaturesOfStudy String
|
||||
| CampusUserInvalidFeaturesOfStudy Text
|
||||
| CampusUserInvalidAssociatedSchools Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception CampusUserConversionException
|
||||
|
||||
@ -3134,7 +3137,7 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
|
||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
@ -3165,6 +3168,44 @@ upsertCampusUser ldapData Creds{..} = do
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
|
||||
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
|
||||
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
|
||||
void $ insertUnique UserSchool
|
||||
{ userSchoolUser = userId
|
||||
, userSchoolSchool = schoolTermsSchool
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
|
||||
let
|
||||
userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools
|
||||
userAssociatedSchools' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserSchoolAssociation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
|
||||
|
||||
forM_ ss $ \frag -> void . runMaybeT $ do
|
||||
let
|
||||
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
||||
infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do
|
||||
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
||||
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
||||
return schoolLdap
|
||||
Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
|
||||
ssh <- hoistMaybe schoolLdapSchool
|
||||
|
||||
lift . void $ insertUnique UserSchool
|
||||
{ userSchoolUser = userId
|
||||
, userSchoolSchool = ssh
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
forM_ ss $ void . insertUnique . SchoolLdap Nothing
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
|
||||
@ -289,6 +289,7 @@ instance Button UniWorX ButtonAdminStudyTerms where
|
||||
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
||||
getAdminFeaturesR = postAdminFeaturesR
|
||||
postAdminFeaturesR = do
|
||||
uid <- requireAuthId
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
|
||||
let btnForm = wrapForm btnWdgt def
|
||||
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||
@ -322,11 +323,21 @@ postAdminFeaturesR = do
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
||||
( (degreeResult,degreeTable)
|
||||
, (studyTermsResult,studytermsTable)
|
||||
, ((), candidateTable)) <- runDB $ (,,)
|
||||
<$> mkDegreeTable
|
||||
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
||||
(Set.fromList $ map entityKey infConflicts)
|
||||
<*> mkCandidateTable
|
||||
, ((), candidateTable)
|
||||
, userSchools) <- runDB $ do
|
||||
schools <- E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \schoolFunction ->
|
||||
E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
|
||||
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
return school
|
||||
(,,,)
|
||||
<$> mkDegreeTable
|
||||
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
||||
(Set.fromList $ map entityKey infConflicts)
|
||||
(Set.fromList schools)
|
||||
<*> mkCandidateTable
|
||||
<*> pure schools
|
||||
|
||||
-- This needs to happen after calls to `dbTable` so they can short-circuit correctly
|
||||
unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
|
||||
@ -341,12 +352,16 @@ postAdminFeaturesR = do
|
||||
void . runDB $ Map.traverseWithKey updateDegree res
|
||||
addMessageI Success MsgStudyDegreeChangeSuccess
|
||||
|
||||
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text))
|
||||
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
|
||||
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
||||
(\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName
|
||||
, row ^. _dbrOutput . _entityVal . _studyTermsShorthand
|
||||
(\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
|
||||
, row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
|
||||
, row ^. _dbrOutput . _2
|
||||
))
|
||||
updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
|
||||
updateStudyTerms studyTermsKey (name,short,schools) = do
|
||||
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
|
||||
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
|
||||
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
|
||||
formResult studyTermsResult' $ \res -> do
|
||||
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
||||
addMessageI Success MsgStudyTermsChangeSuccess
|
||||
@ -355,24 +370,41 @@ postAdminFeaturesR = do
|
||||
setTitleI MsgAdminFeaturesHeading
|
||||
$(widgetFile "adminFeatures")
|
||||
where
|
||||
textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey))
|
||||
textInputCell :: Ord i
|
||||
=> Lens' a (Maybe Text)
|
||||
-> Getter (DBRow r) (Maybe Text)
|
||||
-> Getter (DBRow r) i
|
||||
-> DBRow r
|
||||
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
|
||||
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
||||
<$> mopt textField "" (Just $ row ^. lensDefault)
|
||||
)
|
||||
|
||||
checkboxCell :: Ord i
|
||||
=> Lens' a Bool
|
||||
-> Getter (DBRow r) Bool
|
||||
-> Getter (DBRow r) i
|
||||
-> DBRow r
|
||||
-> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r)))
|
||||
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
||||
)
|
||||
|
||||
|
||||
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
|
||||
mkDegreeTable =
|
||||
let dbtIdent = "admin-studydegrees" :: Text
|
||||
dbtStyle = def
|
||||
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery ( E.SqlExpr (Entity StudyDegree))
|
||||
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
||||
dbtSQLQuery = return
|
||||
dbtRowKey = (E.^. StudyDegreeKey)
|
||||
dbtProj = return
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
||||
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
|
||||
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
|
||||
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
||||
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
|
||||
, dbRow
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
@ -390,20 +422,29 @@ postAdminFeaturesR = do
|
||||
dbtCsvDecode = Nothing
|
||||
in dbTable psValidator DBTable{..}
|
||||
|
||||
mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
|
||||
mkStudytermsTable newKeys badKeys =
|
||||
mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
|
||||
mkStudytermsTable newKeys badKeys schools =
|
||||
let dbtIdent = "admin-studyterms" :: Text
|
||||
dbtStyle = def
|
||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
|
||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
||||
dbtSQLQuery = return
|
||||
dbtRowKey = (E.^. StudyTermsKey)
|
||||
dbtProj = return
|
||||
dbtProj field = do
|
||||
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
|
||||
E.where_ . E.exists . E.from $ \schoolTerms ->
|
||||
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
||||
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field ^. _dbrOutput . _entityKey)
|
||||
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
|
||||
return $ school E.^. SchoolId
|
||||
return $ field & _dbrOutput %~ (, fieldSchools)
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
|
||||
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
|
||||
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
|
||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
|
||||
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
|
||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
||||
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
|
||||
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
|
||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
|
||||
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
|
||||
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
|
||||
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
|
||||
, dbRow
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
|
||||
@ -279,7 +279,7 @@ validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Co
|
||||
validateCourse CourseForm{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- liftHandlerT requireAuthId
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolShowR
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
|
||||
|
||||
@ -531,7 +531,7 @@ upsertAllocationCourse cid cfAllocation = do
|
||||
Course{..} <- getJust cid
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR courseSchool SchoolShowR
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR courseSchool SchoolEditR
|
||||
|
||||
doEdit <- if
|
||||
| userAdmin
|
||||
|
||||
@ -6,11 +6,16 @@ import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text as Text
|
||||
|
||||
|
||||
getSchoolListR :: Handler Html
|
||||
getSchoolListR = do
|
||||
let
|
||||
schoolLink :: SchoolId -> SomeRoute UniWorX
|
||||
schoolLink ssh = SomeRoute $ SchoolR ssh SchoolShowR
|
||||
schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR
|
||||
|
||||
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
||||
dbtSQLQuery = return
|
||||
@ -57,25 +62,33 @@ getSchoolListR = do
|
||||
data SchoolForm = SchoolForm
|
||||
{ sfShorthand :: CI Text
|
||||
, sfName :: CI Text
|
||||
, sfOrgUnits :: Set (CI Text)
|
||||
}
|
||||
|
||||
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
|
||||
mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
||||
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
|
||||
<*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
|
||||
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) <$> massInputListA (textField & addDatalist ldapOrgs) (const $ "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (fmap CI.original . Set.toList . sfOrgUnits <$> template))
|
||||
where
|
||||
ldapOrgs :: WidgetT UniWorX IO (Set (CI Text))
|
||||
ldapOrgs = liftHandlerT . runDB $
|
||||
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
|
||||
|
||||
schoolToForm :: SchoolId -> DB (Form SchoolForm)
|
||||
schoolToForm ssh = do
|
||||
School{..} <- get404 ssh
|
||||
ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
|
||||
return . mkSchoolForm (Just ssh) $ Just SchoolForm
|
||||
{ sfShorthand = schoolShorthand
|
||||
, sfName = schoolName
|
||||
, sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
|
||||
}
|
||||
|
||||
|
||||
getSchoolShowR, postSchoolShowR :: SchoolId -> Handler Html
|
||||
getSchoolShowR = postSchoolShowR
|
||||
postSchoolShowR ssh = do
|
||||
getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
|
||||
getSchoolEditR = postSchoolEditR
|
||||
postSchoolEditR ssh = do
|
||||
sForm <- runDB $ schoolToForm ssh
|
||||
|
||||
((sfResult, sfView), sfEnctype) <- runFormPost sForm
|
||||
@ -83,12 +96,20 @@ postSchoolShowR ssh = do
|
||||
formResult sfResult $ \SchoolForm{..} -> do
|
||||
runDB $ do
|
||||
update ssh [ SchoolName =. sfName ]
|
||||
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
|
||||
void $ upsert SchoolLdap
|
||||
{ schoolLdapSchool = Just ssh
|
||||
, ..
|
||||
}
|
||||
[ SchoolLdapSchool =. Just ssh
|
||||
]
|
||||
deleteWhere [SchoolLdapSchool ==. Just ssh, SchoolLdapOrgUnit /<-. Set.toList sfOrgUnits]
|
||||
addMessageI Success $ MsgSchoolUpdated ssh
|
||||
redirect $ SchoolR ssh SchoolShowR
|
||||
redirect $ SchoolR ssh SchoolEditR
|
||||
|
||||
let sfView' = wrapForm sfView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ SchoolR ssh SchoolShowR
|
||||
, formAction = Just . SomeRoute $ SchoolR ssh SchoolEditR
|
||||
, formEncoding = sfEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
@ -108,22 +129,29 @@ postSchoolNewR = do
|
||||
formResult sfResult $ \SchoolForm{..} -> do
|
||||
let ssh = SchoolKey sfShorthand
|
||||
insertOkay <- runDB $ do
|
||||
didInsert <- fmap (is _Just) $ insertUnique School
|
||||
didInsert <- is _Just <$> insertUnique School
|
||||
{ schoolShorthand = sfShorthand
|
||||
, schoolName = sfName
|
||||
}
|
||||
when didInsert $
|
||||
when didInsert $ do
|
||||
insert_ UserFunction
|
||||
{ userFunctionUser = uid
|
||||
, userFunctionSchool = ssh
|
||||
, userFunctionFunction = SchoolAdmin
|
||||
}
|
||||
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
|
||||
void $ upsert SchoolLdap
|
||||
{ schoolLdapSchool = Just ssh
|
||||
, ..
|
||||
}
|
||||
[ SchoolLdapSchool =. Just ssh
|
||||
]
|
||||
return didInsert
|
||||
|
||||
if
|
||||
| insertOkay -> do
|
||||
addMessageI Success $ MsgSchoolCreated ssh
|
||||
redirect $ SchoolR ssh SchoolShowR
|
||||
redirect $ SchoolR ssh SchoolEditR
|
||||
| otherwise
|
||||
-> addMessageI Error $ MsgSchoolExists ssh
|
||||
|
||||
|
||||
@ -257,7 +257,14 @@ newTermForm template html = do
|
||||
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
|
||||
| otherwise
|
||||
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
|
||||
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
|
||||
holidayForm = massInputListA
|
||||
dayField
|
||||
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
|
||||
(const Nothing)
|
||||
("holidays" :: Text)
|
||||
(fslI MsgTermHolidays & setTooltip MsgMassInputTip)
|
||||
True
|
||||
(tftHolidays template)
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ Term
|
||||
<$> tidForm
|
||||
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
|
||||
|
||||
@ -7,7 +7,7 @@ module Handler.Utils.Form.MassInput
|
||||
, massInput
|
||||
, module Handler.Utils.Form.MassInput.Liveliness
|
||||
, massInputA, massInputW
|
||||
, massInputList
|
||||
, massInputList, massInputListA
|
||||
, massInputAccum, massInputAccumA, massInputAccumW
|
||||
, massInputAccumEdit, massInputAccumEditA, massInputAccumEditW
|
||||
, ListLength(..), ListPosition(..), miDeleteList
|
||||
@ -486,6 +486,22 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m
|
||||
miRequired
|
||||
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
|
||||
|
||||
massInputListA :: forall handler cellResult ident.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, MonadLogger handler
|
||||
, PathPiece ident
|
||||
)
|
||||
=> Field handler cellResult
|
||||
-> (ListPosition -> FieldSettings UniWorX)
|
||||
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
||||
-> ident
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> Maybe [cellResult]
|
||||
-> AForm handler [cellResult]
|
||||
massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = formToAForm . fmap (over _2 pure) $ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult mempty
|
||||
|
||||
|
||||
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
|
||||
massInputAccum :: forall handler cellData ident.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
|
||||
@ -157,7 +157,7 @@ parseRating File{ fileContent = Just input, .. } = do
|
||||
ratingStr = Text.unpack $ Text.strip ratingLine
|
||||
ratingPoints <- case () of
|
||||
_ | null ratingStr -> return Nothing
|
||||
| otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
|
||||
| otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr
|
||||
return Rating'{ ratingTime = Just fileModified, .. }
|
||||
parseRating _ = throwM RatingFileIsDirectory
|
||||
|
||||
|
||||
32
src/Handler/Utils/SchoolLdap.hs
Normal file
32
src/Handler/Utils/SchoolLdap.hs
Normal file
@ -0,0 +1,32 @@
|
||||
module Handler.Utils.SchoolLdap
|
||||
( parseLdapSchools
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (try, (<|>), choice)
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
|
||||
parseLdapSchools = parse pLdapSchools ""
|
||||
|
||||
pLdapSchools :: Parser (Set (CI Text))
|
||||
pLdapSchools = Set.fromList . map CI.mk <$> pSegment `sepBy` char ','
|
||||
|
||||
pSegment :: Parser Text
|
||||
pSegment = do
|
||||
let
|
||||
fragStart = flip label "fragment start" $ do
|
||||
void . choice . map (try . string) $ sortOn Down
|
||||
[ "l", "st", "o", "ou", "c", "street", "dc" ]
|
||||
void $ char '='
|
||||
|
||||
fragStart
|
||||
pack <$> manyTill anyChar (try (lookAhead $ char ',' >> fragStart) <|> eof)
|
||||
|
||||
@ -8,8 +8,8 @@ import Text.Parsec
|
||||
import Text.Parsec.Text
|
||||
|
||||
|
||||
parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
|
||||
parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
|
||||
parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
|
||||
parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
|
||||
|
||||
|
||||
pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
|
||||
|
||||
@ -11,7 +11,7 @@ import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
ihamletSomeMessage f trans rUrl = f (trans . SomeMessage) rUrl
|
||||
ihamletSomeMessage f trans = f $ trans . SomeMessage
|
||||
|
||||
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
mkEditNotifications uid = liftHandlerT $ do
|
||||
|
||||
@ -25,7 +25,7 @@ data Rating' = Rating'
|
||||
data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
|
||||
| RatingMissingSeparator -- ^ Could not split rating header from comments
|
||||
| RatingMultiple -- ^ Encountered multiple point values in rating
|
||||
| RatingInvalid String -- ^ Failed to parse rating point value
|
||||
| RatingInvalid Text -- ^ Failed to parse rating point value
|
||||
| RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
|
||||
| RatingNegative -- ^ Rating points must be non-negative
|
||||
| RatingExceedsMax -- ^ Rating point must not exceed maximum points
|
||||
|
||||
@ -43,6 +43,9 @@ _nullable = prism' toNullable fromNullable
|
||||
_SchoolId :: Iso' SchoolId SchoolShorthand
|
||||
_SchoolId = iso unSchoolKey SchoolKey
|
||||
|
||||
_Maybe :: Iso' (Maybe ()) Bool
|
||||
_Maybe = iso (maybe False $ const True) (bool Nothing (Just ()))
|
||||
|
||||
|
||||
-----------------------------------
|
||||
-- Lens Definitions for our Types
|
||||
@ -168,6 +171,7 @@ makeLenses_ ''Allocation
|
||||
makeLenses_ ''File
|
||||
|
||||
makeLenses_ ''School
|
||||
makeLenses_ ''SchoolLdap
|
||||
|
||||
makeLenses_ ''UserFunction
|
||||
|
||||
|
||||
@ -1,14 +1,10 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
<td>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
<td>
|
||||
<td>
|
||||
^{addWdgts ! (0, 0)}
|
||||
<div .massinput-list__wrapper>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<div .massinput-list__cell .massinput__cell>
|
||||
<div .massinput-list__field>
|
||||
^{cellWdgts ! coord}
|
||||
<div .massinput-list__delete>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<div .massinput-list__add .massinput__cell .massinput__cell--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
|
||||
@ -241,17 +241,17 @@ fillDb = do
|
||||
}
|
||||
ifi <- insert' $ School "Institut für Informatik" "IfI"
|
||||
mi <- insert' $ School "Institut für Mathematik" "MI"
|
||||
void . insert' $ UserAdmin gkleen ifi
|
||||
void . insert' $ UserAdmin gkleen mi
|
||||
void . insert' $ UserAdmin fhamann ifi
|
||||
void . insert' $ UserAdmin jost ifi
|
||||
void . insert' $ UserAdmin jost mi
|
||||
void . insert' $ UserAdmin svaupel ifi
|
||||
void . insert' $ UserAdmin svaupel mi
|
||||
void . insert' $ UserLecturer gkleen ifi
|
||||
void . insert' $ UserLecturer fhamann ifi
|
||||
void . insert' $ UserLecturer jost ifi
|
||||
void . insert' $ UserLecturer svaupel ifi
|
||||
void . insert' $ UserFunction gkleen ifi SchoolAdmin
|
||||
void . insert' $ UserFunction gkleen mi SchoolAdmin
|
||||
void . insert' $ UserFunction fhamann ifi SchoolAdmin
|
||||
void . insert' $ UserFunction jost ifi SchoolAdmin
|
||||
void . insert' $ UserFunction jost mi SchoolAdmin
|
||||
void . insert' $ UserFunction svaupel ifi SchoolAdmin
|
||||
void . insert' $ UserFunction svaupel mi SchoolAdmin
|
||||
void . insert' $ UserFunction gkleen ifi SchoolLecturer
|
||||
void . insert' $ UserFunction fhamann ifi SchoolLecturer
|
||||
void . insert' $ UserFunction jost ifi SchoolLecturer
|
||||
void . insert' $ UserFunction svaupel ifi SchoolLecturer
|
||||
let
|
||||
sdBsc = StudyDegreeKey' 82
|
||||
sdMst = StudyDegreeKey' 88
|
||||
|
||||
@ -23,6 +23,10 @@ instance Arbitrary (Route EmbeddedStatic) where
|
||||
paramNum <- getNonNegative <$> arbitrary
|
||||
params <- replicateM paramNum $ (,) <$> printableText <*> printableText
|
||||
return $ embeddedResourceR path params
|
||||
|
||||
instance Arbitrary SchoolR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary CourseR where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
18
test/Handler/Utils/SchoolLdapSpec.hs
Normal file
18
test/Handler/Utils/SchoolLdapSpec.hs
Normal file
@ -0,0 +1,18 @@
|
||||
module Handler.Utils.SchoolLdapSpec where
|
||||
|
||||
import TestImport
|
||||
|
||||
import Handler.Utils.SchoolLdap
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "ldap school extraction" $ do
|
||||
it "works for some examples" . example $ do
|
||||
let matches str frags = parseLdapSchools str `shouldBe` Right (Set.fromList frags)
|
||||
|
||||
"ou=Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat),o=uni-muenchen,c=de" `matches` ["Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat)", "uni-muenchen", "de"]
|
||||
"ou=Katholisch-Theologische Fakultät (01 Fak. Kathol. Theologie),o=uni-muenchen,c=de" `matches` ["Katholisch-Theologische Fakultät (01 Fak. Kathol. Theologie)", "uni-muenchen", "de"]
|
||||
"ou=C4-Professur für Informatik (1603 C4 Hofmann),ou=Department Institut für Informatik (1603 Dept. Informatik),ou=Fakultät für Mathematik, Informatik und Statistik (16 Fak. Mathe Info. Stat.),o=uni-muenchen,c=de" `matches` ["C4-Professur für Informatik (1603 C4 Hofmann)", "Department Institut für Informatik (1603 Dept. Informatik)", "Fakultät für Mathematik, Informatik und Statistik (16 Fak. Mathe Info. Stat.)", "uni-muenchen", "de"]
|
||||
"ou=Department Mathematisches Institut (1601_Dept_Mathemat_Inst),ou=Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat),o=uni-muenchen,c=de" `matches` ["Department Mathematisches Institut (1601_Dept_Mathemat_Inst)", "Fakultät für Mathematik, Informatik und Statistik (16_Fak_Mathe_Info_Stat)", "uni-muenchen", "de"]
|
||||
"ou=Fakultät für Physik (17_Fakultät_Physik),o=uni-muenchen,c=de" `matches` ["Fakultät für Physik (17_Fakultät_Physik)", "uni-muenchen", "de"]
|
||||
Loading…
Reference in New Issue
Block a user