diff --git a/frontend/src/services/html-helpers/html-helpers.js b/frontend/src/services/html-helpers/html-helpers.js index b8bf7771b..5799fee24 100644 --- a/frontend/src/services/html-helpers/html-helpers.js +++ b/frontend/src/services/html-helpers/html-helpers.js @@ -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) => { diff --git a/frontend/src/utils/mass-input/mass-input.js b/frontend/src/utils/mass-input/mass-input.js index 87d17c8c3..400c64429 100644 --- a/frontend/src/utils/mass-input/mass-input.js +++ b/frontend/src/utils/mass-input/mass-input.js @@ -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'; diff --git a/frontend/src/utils/mass-input/mass-input.scss b/frontend/src/utils/mass-input/mass-input.scss new file mode 100644 index 000000000..d8f006d36 --- /dev/null +++ b/frontend/src/utils/mass-input/mass-input.scss @@ -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; +} diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 6194df7d2..43a3c5673 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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}“ diff --git a/models/schools b/models/schools index da7859057..2da425cf4 100644 --- a/models/schools +++ b/models/schools @@ -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 \ No newline at end of file + UniqueOrgUnit orgUnit +SchoolTerms + school SchoolId + terms StudyTermsId \ No newline at end of file diff --git a/models/users b/models/users index 330102901..0b23d02a2 100644 --- a/models/users +++ b/models/users @@ -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 diff --git a/routes b/routes index fe7902d98..2461c235c 100644 --- a/routes +++ b/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: diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e14a79b9a..74c669f3c 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 74bfbb7d6..c038f2152 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 7d0354425..4390305fb 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 ()) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index db6096bec..9d8c03552 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 5888fecd6..a6a1e4159 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -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 diff --git a/src/Handler/School.hs b/src/Handler/School.hs index d5cd61820..9223689b6 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 26cba329a..ba4be993c 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -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) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 7e2131ae3..87dcc7a85 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 5549766dc..1884cbe09 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -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 diff --git a/src/Handler/Utils/SchoolLdap.hs b/src/Handler/Utils/SchoolLdap.hs new file mode 100644 index 000000000..b9b825aff --- /dev/null +++ b/src/Handler/Utils/SchoolLdap.hs @@ -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) + diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index d2903309c..c3662286a 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -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] diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs index 1a528ff73..b4bee1803 100644 --- a/src/Jobs/Handler/SendNotification/Utils.hs +++ b/src/Jobs/Handler/SendNotification/Utils.hs @@ -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 diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index 295d275eb..0e2fcf8cb 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 9f908a96b..7d082f255 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -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 diff --git a/templates/widgets/massinput/list/layout.hamlet b/templates/widgets/massinput/list/layout.hamlet index 63d64a53a..8d8776c62 100644 --- a/templates/widgets/massinput/list/layout.hamlet +++ b/templates/widgets/massinput/list/layout.hamlet @@ -1,14 +1,10 @@ $newline never - - - $forall coord <- review liveCoords lLength - - - -
- ^{cellWdgts ! coord} - - ^{fvInput (delButtons ! coord)} -
- - ^{addWdgts ! (0, 0)} +
+ $forall coord <- review liveCoords lLength +
+
+ ^{cellWdgts ! coord} +
+ ^{fvInput (delButtons ! coord)} +
+ ^{addWdgts ! (0, 0)} diff --git a/test/Database.hs b/test/Database.hs index fc4396918..6a02c9d2d 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -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 diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index d84e2ee7d..b2f2c1fa5 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -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 diff --git a/test/Handler/Utils/SchoolLdapSpec.hs b/test/Handler/Utils/SchoolLdapSpec.hs new file mode 100644 index 000000000..4b9401e23 --- /dev/null +++ b/test/Handler/Utils/SchoolLdapSpec.hs @@ -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"]