chore(ldap): add ldap parsing test to ldap admin route

messages/uniworx/categories/authorization/de-de-formal.msg

@@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login
 PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
 DummyLoginTitle: Development-Login
 InternalLdapError: Interner Fehler beim Fraport Büko-Login
-CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation
+CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
 CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
 CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
 CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln

src/Foundation/Yesod/Auth.hs

@@ -1,6 +1,7 @@
 module Foundation.Yesod.Auth
   ( authenticate
   , upsertCampusUser
+  , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
   ) where
@@ -154,41 +155,45 @@ upsertCampusUser :: forall m.
                  => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
 upsertCampusUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
-  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+  userDefaultConf <- getsYesod $ view _appUserDefaults
+
+  (newUser@User{..},userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
+  oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
+
+  user@(Entity userId userRec) <- case oldUsers of
+    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
+    _other           -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
+  unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $
+    update userId [ UserDisplayName =. userDisplayName ]
 
   let
-    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
+    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
+    userSystemFunctions' = do
+      (k, v) <- ldapData
+      guard $ k == ldapAffiliation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      assertM' (not . Text.null) $ Text.strip str
 
-    -- only accept a single result, throw error otherwise
+  iforM_ userSystemFunctions $ \func preset -> do
-    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+    memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
-    decodeLdap1 attr err 
+    if | preset -> void $ upsert (UserSystemFunction userId func False False) []
-      | [bs] <- ldapMap !!! attr 
+       | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
-      , Right t <- Text.decodeUtf8' bs
-        = return t
-      | otherwise = throwM err
 
-    -- accept multiple successful decodings, ignoring all others 
+  return user
-    decodeLdapN attr err
-        | t@(_:_) <- rights vs
-          = return $ Text.unwords t
-        | otherwise = throwM err
-      where 
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
-    -- accept any successful decoding or empty; only throw an error if all decodings fail
+decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
+        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
-    decodeLdap' attr err
+decodeUserTest mbIdent ldapData = do
-        | []    <-        vs = return   Nothing
+    now <- liftIO getCurrentTime
-        | (h:_) <- rights vs = return $ Just h
+    userDefaultConf <- getsYesod $ view _appUserDefaults
-        | otherwise          = throwM err        
+    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
-      where 
+    try $ decodeUser now userDefaultConf mode ldapData
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
-    -- just returns Nothing on error, pure
-    decodeLdap :: Ldap.Attr -> Maybe Text
-    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
 
+decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do
+    let
       userTelephone             = decodeLdap ldapUserTelephone
       userMobile                = decodeLdap ldapUserMobile
       userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
@@ -272,30 +277,40 @@ upsertCampusUser upsertMode ldapData = do
                     , UserCompanyDepartment       =. userCompanyDepartment
                     ] ++
                     [ UserLastAuthentication =. Just now | isLogin ]
+    return (newUser, userUpdate)
 
-  oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
+  where
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
+    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
 
-  user@(Entity userId userRec) <- case oldUsers of
+    -- only accept a single result, throw error otherwise
-    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
+    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    _other           -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
+    decodeLdap1 attr err
-  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
+      | [bs] <- ldapMap !!! attr
-    update userId [ UserDisplayName =. userDisplayName' ]
+      , Right t <- Text.decodeUtf8' bs
+        = return t
+      | otherwise = throwM err
 
-  let
+    -- accept multiple successful decodings, ignoring all others
-    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
+    decodeLdapN attr err
-    userSystemFunctions' = do
+        | t@(_:_) <- rights vs
-      (k, v) <- ldapData
+          = return $ Text.unwords t
-      guard $ k == ldapAffiliation
+        | otherwise = throwM err
-      v' <- v
+      where
-      Right str <- return $ Text.decodeUtf8' v'
+        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-      assertM' (not . Text.null) $ Text.strip str
 
-  iforM_ userSystemFunctions $ \func preset -> do
+    -- accept any successful decoding or empty; only throw an error if all decodings fail
-    memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
+    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
-    if | preset -> void $ upsert (UserSystemFunction userId func False False) []
+    decodeLdap' attr err
-       | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
+        | []    <-        vs = return   Nothing
+        | (h:_) <- rights vs = return $ Just h
+        | otherwise          = throwM err
+      where
+        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
-  return user
+    -- just returns Nothing on error, pure
+    decodeLdap :: Ldap.Attr -> Maybe Text
+    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do

src/Handler/Admin/Ldap.hs

@@ -8,9 +8,11 @@ module Handler.Admin.Ldap
 import Import
 -- import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
+import qualified Data.CaseInsensitive as CI
 -- import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 -- import qualified Data.Set  as Set
+import Foundation.Yesod.Auth (decodeUserTest)
 
 import Handler.Utils
 
@@ -49,11 +51,16 @@ postAdminLdapR = do
   let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
       procFormPerson LdapQueryPerson{..} = do     
         ldapPool'       <- getsYesod $ view _appLdapPool
+
         if isNothing ldapPool'
           then addMessage Warning $ text2Html "LDAP Configuration missing."
           else addMessage Info    $ text2Html "Input for LDAP test received."
-        fmap join . for ldapPool' $ \ldapPool ->
+        fmap join . for ldapPool' $ \ldapPool -> do 
-          campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
+          ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
+          eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
+          whenIsLeft eitherErr $ addMessageI Error 
+          return ldapData
+
           
   mbLdapData <- formResultMaybe presult procFormPerson