refactor(ldap login): cleanup & better error messages

messages/uniworx/de.msg

@@ -553,6 +553,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp
 DummyLoginTitle: Development-Login
 LoginNecessary: Bitte melden Sie sich dazu vorher an!
 
+InternalLdapError: Interner Fehler beim Campus-Login
+
+CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln
+CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln
+CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln
+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}
+
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt

src/Auth/LDAP.hs

@@ -1,9 +1,12 @@
 module Auth.LDAP
-  ( campusLogin
+  ( apLdap
+  , campusLogin
   , CampusUserException(..)
   , campusUser
   , CampusMessage(..)
-  , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
+  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
+  , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
+  , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
   ) where
 
 import Import.NoFoundation hiding (userEmail, userDisplayName)
@@ -42,12 +45,12 @@ findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
 findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
   where
     userFilters =
-      [ userPrincipalName Ldap.:= Text.encodeUtf8 ident
+      [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
-      , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 ident
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 ident
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userDisplayName   Ldap.:= Text.encodeUtf8 ident
+      , ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
       ]
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
@@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
       , Ldap.derefAliases Ldap.DerefAlways
       ]
 
-userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
+ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
-userPrincipalName = Ldap.Attr "userPrincipalName"
+ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
-userEmail         = Ldap.Attr "mail"
+ldapUserEmail         = Ldap.Attr "mail"
-userDisplayName   = Ldap.Attr "displayName"
+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" 
+
+
+data CampusUserException = CampusUserLdapError LdapPoolError
+                         | CampusUserHostNotResolved String
+                         | CampusUserLineTooLong
+                         | CampusUserHostCannotConnect String [IOException]
+                         | CampusUserNoResult
+                         | CampusUserAmbiguous
+  deriving (Show, Eq, Generic, Typeable)
+
+instance Exception CampusUserException
+
+campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
+campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+  Ldap.bind ldap ldapDn ldapPassword
+  results <- case lookup "DN" credsExtra of
+    Just userDN -> do
+      let userFilter = Ldap.Present ldapUserPrincipalName
+          userSearchSettings = mconcat
+            [ Ldap.scope Ldap.BaseObject
+            , Ldap.size 2
+            , Ldap.time ldapSearchTimeout
+            , Ldap.derefAliases Ldap.DerefAlways
+            ]
+      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
+    Nothing -> do
+      findUser conf ldap credsIdent []
+  case results of
+    [] -> throwM CampusUserNoResult
+    [Ldap.SearchEntry _ attrs] -> return attrs
+    _otherwise -> throwM CampusUserAmbiguous
+  where
+    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
+                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
+                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
+                  ]
+
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
@@ -69,6 +115,9 @@ campusForm = CampusLogin
   <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
   <*> areq passwordField (fslI MsgCampusPassword) Nothing
 
+apLdap :: Text
+apLdap = "LDAP"
+
 campusLogin :: forall site.
                ( YesodAuth site
                , RenderMessage site FormMessage
@@ -78,7 +127,7 @@ campusLogin :: forall site.
                ) => LdapConf -> LdapPool -> AuthPlugin site
 campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
-    apName = "LDAP"
+    apName = apLdap
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
     apDispatch "POST" [] = do
       ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
@@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
           ldapResult <- withLdap pool $ \ldap -> do
             Ldap.bind ldap ldapDn ldapPassword
-            searchResults <- findUser conf ldap campusIdent [userPrincipalName]
+            searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
             case searchResults of
               [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
-                | Just [principalName] <- lookup userPrincipalName userAttrs
+                | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
                 , Right credsIdent <- Text.decodeUtf8' principalName
                 -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
               other -> return $ Left other
@@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
             , formAnchor = Just "login--campus" :: Maybe Text
             }
       $(widgetFile "widgets/campus-login/campus-login-form")
-
-data CampusUserException = CampusUserLdapError LdapPoolError
-                         | CampusUserHostNotResolved String
-                         | CampusUserLineTooLong
-                         | CampusUserHostCannotConnect String [IOException]
-                         | CampusUserNoResult
-                         | CampusUserAmbiguous
-  deriving (Show, Eq, Generic, Typeable)
-
-instance Exception CampusUserException
-
-campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
-campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
-  Ldap.bind ldap ldapDn ldapPassword
-  results <- case lookup "DN" credsExtra of
-    Just userDN -> do
-      let userFilter = Ldap.Present userPrincipalName
-          userSearchSettings = mconcat
-            [ Ldap.scope Ldap.BaseObject
-            , Ldap.size 2
-            , Ldap.time ldapSearchTimeout
-            , Ldap.derefAliases Ldap.DerefAlways
-            ]
-      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
-    Nothing -> do
-      findUser conf ldap credsIdent []
-  case results of
-    [] -> throwM CampusUserNoResult
-    [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM CampusUserAmbiguous
-  where
-    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
-                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
-                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
-                  ]
-
--- ldapConfig :: UniWorX -> LDAPConfig
--- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
---   { usernameFilter = \u -> principalName <> "=" <> u
---   , identifierModifier
---   , ldapUri = appLDAPURI settings
---   , initDN = appLDAPDN settings
---   , initPass = appLDAPPw settings
---   , baseDN = appLDAPBaseName settings
---   , ldapScope = LdapScopeSubtree
---   }
---   where
---     principalName :: IsString a => a
---     principalName = "userPrincipalName"
---     identifierModifier _ entry = case lookup principalName $ leattrs entry of
---       Just [n] -> Text.pack n
---       _        -> error "Could not determine user principal name"

src/Foundation.hs

@@ -55,7 +55,7 @@ import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
 
-import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
+import Control.Monad.Except (MonadError(..), ExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
@@ -88,6 +88,8 @@ import qualified Data.Aeson as JSON
 
 import Data.FileEmbed (embedFile)
 
+import qualified Ldap.Client as Ldap
+
 
 type SMTPPool = Pool SMTPConnection
 
@@ -2732,6 +2734,155 @@ instance YesodPersist UniWorX where
 instance YesodPersistRunner UniWorX where
     getDBRunner = defaultGetDBRunner appConnPool
 
+data CampusUserConversionException
+  = CampusUserInvalidEmail
+  | CampusUserInvalidDisplayName
+  | CampusUserInvalidGivenName
+  | CampusUserInvalidSurname
+  | CampusUserInvalidTitle
+  | CampusUserInvalidMatriculation
+  | CampusUserInvalidFeaturesOfStudy String
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+instance Exception CampusUserConversionException
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id
+
+upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User)
+upsertCampusUser ldapData Creds{..} = do
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+
+  let
+    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
+    userEmail'          = fold [ v | (k, v) <- ldapData, k == ldapUserEmail         ]
+    userDisplayName'    = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
+
+    userAuthentication
+      | isPWHash  = error "PWHash should only work for users that are already known"
+      | otherwise = AuthLDAP
+    userLastAuthentication = now <$ guard (not isDummy)
+
+  userEmail <- if
+    | [bs] <- userEmail'
+    , Right userEmail <- Text.decodeUtf8' bs
+      -> return $ mk userEmail
+    | otherwise
+      -> throwM CampusUserInvalidEmail
+  userDisplayName <- if
+    | [bs] <- userDisplayName'
+    , Right userDisplayName <- Text.decodeUtf8' bs
+      -> return userDisplayName
+    | otherwise
+      -> throwM CampusUserInvalidDisplayName
+  userFirstName <- if
+    | [bs] <- userFirstName'
+    , Right userFirstName <- Text.decodeUtf8' bs
+      -> return userFirstName
+    | otherwise
+      -> throwM CampusUserInvalidGivenName
+  userSurname <- if
+    | [bs] <- userSurname'
+    , Right userSurname <- Text.decodeUtf8' bs
+      -> return userSurname
+    | otherwise
+      -> throwM CampusUserInvalidSurname
+  userTitle <- if
+    | all ByteString.null userTitle'
+      -> return Nothing
+    | [bs] <- userTitle'
+    , Right userTitle <- Text.decodeUtf8' bs
+      -> return $ Just userTitle
+    | otherwise
+      -> throwM CampusUserInvalidTitle
+  userMatrikelnummer <- if
+    | [bs] <- userMatrikelnummer'
+    , Right userMatrikelnummer <- Text.decodeUtf8' bs
+      -> return $ Just userMatrikelnummer
+    | [] <- userMatrikelnummer'
+      -> return Nothing
+    | otherwise
+      -> throwM CampusUserInvalidMatriculation
+
+  let
+    newUser = User
+      { userIdent                = mk credsIdent
+      , userMaxFavourites        = userDefaultMaxFavourites
+      , userTheme                = userDefaultTheme
+      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateFormat           = userDefaultDateFormat
+      , userTimeFormat           = userDefaultTimeFormat
+      , userDownloadFiles        = userDefaultDownloadFiles
+      , userNotificationSettings = def
+      , userMailLanguages        = def
+      , userTokensIssuedAfter    = Nothing
+      , ..
+      }
+    userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
+                  , UserDisplayName        =. userDisplayName
+                  , UserSurname            =. userSurname
+                  , UserEmail              =. userEmail
+                  ] ++
+                  [ UserLastAuthentication =. Just now | not isDummy ]
+
+  user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate
+
+  let
+    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
+    userStudyFeatures' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserStudyFeatures
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    termNames = nubBy ((==) `on` mk) $ do
+      (k, v) <- ldapData
+      guard $ k == ldapUserFieldName
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
+
+  let
+    studyTermCandidates = Set.fromList $ do
+      name <- termNames
+      StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
+      return (key, name)
+    studyTermCandidateIncidence
+      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
+      . UUID.fromByteString
+      . fromStrict
+      . (convert :: Digest (SHAKE128 128) -> ByteString)
+      . runIdentity
+      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
+
+  [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
+    E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
+
+  unless candidatesRecorded $ do
+    let
+      studyTermCandidates' = do
+        (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
+        return StudyTermCandidate{..}
+    insertMany_ studyTermCandidates'
+
+  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
+  forM_ fs $ \f@StudyFeatures{..} -> do
+    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+    void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
+
+  return user
+  where
+    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
+    isDummy  = credsPlugin == "dummy"
+    isPWHash = credsPlugin == "PWHash"
+
+
 instance YesodAuth UniWorX where
     type AuthId UniWorX = UserId
 
@@ -2761,25 +2912,34 @@ instance YesodAuth UniWorX where
         isDummy = credsPlugin == "dummy"
         isPWHash = credsPlugin == "PWHash"
 
-        excHandlers
+        excRecovery res
           | isDummy || isPWHash
-          = [ C.Handler $ \err -> do
+          = do
-                addMessage Error (toHtml $ tshow (err :: CampusUserException))
+              case res of
-                $logErrorS "LDAP" $ tshow err
+                UserError   err -> addMessageI Error   err
-                acceptExisting
+                ServerError err -> addMessage  Error $ toHtml err
-            ]
+                _other          -> return ()
+              acceptExisting
           | otherwise
-          = [ C.Handler $ \case
+          = return res
-                CampusUserNoResult -> do
+          
-                  $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+        excHandlers =
-                  return . UserError $ IdentifierNotFound credsIdent
+          [ C.Handler $ \case
-                CampusUserAmbiguous -> do
+              CampusUserNoResult -> do
-                  $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+                $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
-                  return . UserError $ IdentifierNotFound credsIdent
+                excRecovery . UserError $ IdentifierNotFound credsIdent
-                err -> do
+              CampusUserAmbiguous -> do
-                  $logErrorS "LDAP" $ tshow err
+                $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
-                  return $ ServerError "LDAP lookup failed"
+                excRecovery . UserError $ IdentifierNotFound credsIdent
-            ]
+              err -> do
+                $logErrorS "LDAP" $ tshow err
+                mr <- getMessageRender
+                excRecovery . ServerError $ mr MsgInternalLdapError
+          , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+              $logErrorS "LDAP" $ tshow cExc
+              mr <- getMessageRender
+              excRecovery . ServerError $ mr cExc
+          ]
 
         acceptExisting = do
           res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
@@ -2792,138 +2952,13 @@ instance YesodAuth UniWorX where
       UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
       flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
-        Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
+        Just (ldapConf, ldapPool) -> do
-          ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra
+          let userCreds = Creds credsPlugin (original userIdent) credsExtra
+          ldapData <- campusUser ldapConf ldapPool userCreds
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-
+          Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
-          let
+        Nothing
-            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
+          -> acceptExisting
-            userEmail' = lookup (Attr "mail") ldapData
-            userDisplayName' = lookup (Attr "displayName") ldapData
-            userFirstName' = lookup (Attr "givenName") ldapData
-            userSurname' = lookup (Attr "sn") ldapData
-            userTitle' = lookup (Attr "title") ldapData
-
-            userAuthentication
-              | isPWHash  = error "PWHash should only work for users that are already known"
-              | otherwise = AuthLDAP
-            userLastAuthentication = now <$ guard (not isDummy)
-
-          userEmail <- if
-            | Just [bs] <- userEmail'
-            , Right userEmail <- Text.decodeUtf8' bs
-              -> return $ mk userEmail
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user email"
-          userDisplayName <- if
-            | Just [bs] <- userDisplayName'
-            , Right userDisplayName <- Text.decodeUtf8' bs
-              -> return userDisplayName
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user name"
-          userFirstName <- if
-            | Just [bs] <- userFirstName'
-            , Right userFirstName <- Text.decodeUtf8' bs
-              -> return userFirstName
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user given name"
-          userSurname <- if
-            | Just [bs] <- userSurname'
-            , Right userSurname <- Text.decodeUtf8' bs
-              -> return userSurname
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user surname"
-          userTitle <- if
-            | maybe True (all ByteString.null) userTitle'
-              -> return Nothing
-            | Just [bs] <- userTitle'
-            , Right userTitle <- Text.decodeUtf8' bs
-              -> return $ Just userTitle
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user title"
-          userMatrikelnummer <- if
-            | Just [bs] <- userMatrikelnummer'
-            , Right userMatrikelnummer <- Text.decodeUtf8' bs
-              -> return $ Just userMatrikelnummer
-            | Nothing <- userMatrikelnummer'
-              -> return Nothing
-            | otherwise
-              -> throwError $ ServerError "Could not decode user matriculation"
-
-          let
-            newUser = User
-              { userMaxFavourites        = userDefaultMaxFavourites
-              , userTheme                = userDefaultTheme
-              , userDateTimeFormat       = userDefaultDateTimeFormat
-              , userDateFormat           = userDefaultDateFormat
-              , userTimeFormat           = userDefaultTimeFormat
-              , userDownloadFiles        = userDefaultDownloadFiles
-              , userNotificationSettings = def
-              , userMailLanguages        = def
-              , userTokensIssuedAfter    = Nothing
-              , ..
-              }
-            userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
-                          , UserDisplayName        =. userDisplayName
-                          , UserSurname            =. userSurname
-                          , UserEmail              =. userEmail
-                          ] ++
-                          [ UserLastAuthentication =. Just now | not isDummy ]
-
-          userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
-
-          let
-            userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
-            userStudyFeatures' = do
-              (k, v) <- ldapData
-              guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
-              v' <- v
-              Right str <- return $ Text.decodeUtf8' v'
-              return str
-
-            termNames = nubBy ((==) `on` mk) $ do
-              (k, v) <- ldapData
-              guard $ k == Attr "dfnEduPersonFieldOfStudyString"
-              v' <- v
-              Right str <- return $ Text.decodeUtf8' v'
-              return str
-
-          fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
-
-          let
-            studyTermCandidates = Set.fromList $ do
-              name <- termNames
-              StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
-              return (key, name)
-            studyTermCandidateIncidence
-              = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
-              . UUID.fromByteString
-              . fromStrict
-              . (convert :: Digest (SHAKE128 128) -> ByteString)
-              . runIdentity
-              $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
-
-          [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
-            E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
-
-          unless candidatesRecorded $ do
-            let
-              studyTermCandidates' = do
-                (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
-                return StudyTermCandidate{..}
-            lift $ insertMany_ studyTermCandidates'
-
-          lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
-          forM_ fs $ \f@StudyFeatures{..} -> do
-            lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-            lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
-            void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
-
-          return $ Authenticated userId
-        Nothing -> acceptExisting
-
-      where
-        insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
     authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool

src/Handler/Users.hs

@@ -260,10 +260,7 @@ postAdminUserR uuid = do
               campusHandler _ = mzero
             campusResult <- runMaybeT . handle campusHandler $ do
                 (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
-                let
+                void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
-                  campusLogin :: AuthPlugin UniWorX
-                  campusLogin = Auth.campusLogin conf pool
-                void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) []
             case campusResult of
               Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
               _other