feat(user-schools): automatically assign users to schools

Based on StudyTerms and SchoolLdap

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) => {

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';

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;
+}

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}“

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
+SchoolTerms
+    school  SchoolId
+    terms   StudyTermsId

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

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:

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, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation :: Ldap.Attr
-ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
+ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
-ldapUserEmail         = Ldap.Attr "mail"
+ldapUserEmail             = Ldap.Attr "mail"
-ldapUserDisplayName   = Ldap.Attr "displayName"
+ldapUserDisplayName       = Ldap.Attr "displayName"
-ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
+ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
-ldapUserFirstName     = Ldap.Attr "givenName"
+ldapUserFirstName         = Ldap.Attr "givenName"
-ldapUserSurname       = Ldap.Attr "sn"
+ldapUserSurname           = Ldap.Attr "sn"
-ldapUserTitle         = Ldap.Attr "title"
+ldapUserTitle             = Ldap.Attr "title"
-ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
+ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
-ldapUserFieldName     = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+ldapUserFieldName         = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" 
 
 
 data CampusUserException = CampusUserLdapError LdapPoolError

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

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 ())

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 $ (,,)
+      , ((), candidateTable)
-      <$> mkDegreeTable
+      , userSchools) <- runDB $ do
-      <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+      schools <- E.select . E.from $ \school -> do
-                            (Set.fromList $ map entityKey infConflicts)
+        E.where_ . E.exists . E.from $ \schoolFunction ->
-      <*> mkCandidateTable
+          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 -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
-                   , row ^. _dbrOutput . _entityVal . _studyTermsShorthand
+                   , 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 "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
+            , 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 :: 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 =
+    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 "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , 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 . _entityKey))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , 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

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

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
+getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
-getSchoolShowR = postSchoolShowR
+getSchoolEditR = postSchoolEditR
-postSchoolShowR ssh = do
+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
 

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)

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

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
 

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)
+  

src/Handler/Utils/StudyFeatures.hs

@@ -8,8 +8,8 @@ import Text.Parsec
 import Text.Parsec.Text
 
 
-parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
+parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
+parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
 
 
 pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]

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

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

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
 

templates/widgets/massinput/list/layout.hamlet

@@ -1,14 +1,10 @@
 $newline never
-<table>
+<div .massinput-list__wrapper>
-  <tbody>
+  $forall coord <- review liveCoords lLength
-    $forall coord <- review liveCoords lLength
+    <div .massinput-list__cell .massinput__cell>
-      <tr .massinput__cell>
+      <div .massinput-list__field>
-        <td>
+        ^{cellWdgts ! coord}
-          ^{cellWdgts ! coord}
+      <div .massinput-list__delete>
-        <td>
+        ^{fvInput (delButtons ! coord)}
-          ^{fvInput (delButtons ! coord)}
+  <div .massinput-list__add .massinput__cell .massinput__cell--add>
-  <tfoot>
+    ^{addWdgts ! (0, 0)}
-    <tr .massinput__cell.massinput__cell--add>
-      <td>
-      <td>
-        ^{addWdgts ! (0, 0)}

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' $ UserFunction gkleen ifi SchoolAdmin
-  void . insert' $ UserAdmin gkleen mi
+  void . insert' $ UserFunction gkleen mi SchoolAdmin
-  void . insert' $ UserAdmin fhamann ifi
+  void . insert' $ UserFunction fhamann ifi SchoolAdmin
-  void . insert' $ UserAdmin jost ifi
+  void . insert' $ UserFunction jost ifi SchoolAdmin
-  void . insert' $ UserAdmin jost mi
+  void . insert' $ UserFunction jost mi SchoolAdmin
-  void . insert' $ UserAdmin svaupel ifi
+  void . insert' $ UserFunction svaupel ifi SchoolAdmin
-  void . insert' $ UserAdmin svaupel mi
+  void . insert' $ UserFunction svaupel mi SchoolAdmin
-  void . insert' $ UserLecturer gkleen ifi
+  void . insert' $ UserFunction gkleen ifi SchoolLecturer
-  void . insert' $ UserLecturer fhamann ifi
+  void . insert' $ UserFunction fhamann ifi SchoolLecturer
-  void . insert' $ UserLecturer jost ifi
+  void . insert' $ UserFunction jost ifi SchoolLecturer
-  void . insert' $ UserLecturer svaupel ifi
+  void . insert' $ UserFunction svaupel ifi SchoolLecturer
   let
     sdBsc = StudyDegreeKey' 82
     sdMst = StudyDegreeKey' 88

test/FoundationSpec.hs

@@ -24,6 +24,10 @@ instance Arbitrary (Route EmbeddedStatic) where
     params <- replicateM paramNum $ (,) <$> printableText <*> printableText
     return $ embeddedResourceR path params
   
+instance Arbitrary SchoolR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary CourseR where
   arbitrary = genericArbitrary
   shrink = genericShrink

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"]