From 4c901239d526297c05de63dc35482cd776806ee7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Dec 2022 16:19:10 +0100 Subject: [PATCH] refactor(avs): fix upsertCampusUserByCn --- src/Auth/LDAP.hs | 2 +- src/Foundation/Yesod/Auth.hs | 24 ++++++++++++++++++------ src/Handler/Admin/Avs.hs | 2 +- src/Handler/Admin/Ldap.hs | 23 +++++++++++------------ src/Handler/Utils/Avs.hs | 19 ++++++++----------- src/Model/Types/Avs.hs | 7 ++++++- test/Utils/TypesSpec.hs | 4 ++-- 7 files changed, 47 insertions(+), 34 deletions(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 23c1eb341..fc225edf4 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -146,7 +146,7 @@ campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover ( campusUserReTest' pool doTest mode User{userIdent} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) []) -campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) +campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 9d4bbb1f2..e43fa0b7b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,7 +4,8 @@ module Foundation.Yesod.Auth ( authenticate - , upsertCampusUser, upsertCampusUserByCn + , ldapLookupAndUpsert + , upsertCampusUser , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage @@ -106,10 +107,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - UniWorX{..} <- getYesod + $logDebugS "auth" $ tshow Creds{..} + ldapPool' <- getsYesod $ view _appLdapPool - flip catches excHandlers $ case appLdapPool of + flip catches excHandlers $ case ldapPool' of Just ldapPool | Just upsertMode' <- upsertMode -> do ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} @@ -152,14 +153,25 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash +ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) +ldapLookupAndUpsert ident = + getsYesod (view _appLdapPool) >>= \case + Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." + Just ldapPool -> + campusUser'' ldapPool campusUserFailoverMode ident >>= \case + Nothing -> throwM CampusUserNoResult + Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse + +{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP! upsertCampusUserByCn :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m ) => Text -> SqlPersistT m (Entity User) upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] +-} - +-- | Upsert User DB according to given LDAP data (does not query LDAP itself) upsertCampusUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -208,7 +220,7 @@ decodeUserTest mbIdent ldapData = do decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) -decodeUser now UserDefaultConf{..} upsertMode ldapData = do +decodeUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone userMobile = decodeLdap ldapUserMobile diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 26e0fac42..6d24f2ffa 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -38,7 +38,7 @@ avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field avsCardNoField = convertField AvsCardNo avsCardNo textField avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo -avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField +avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 6389dc807..c3ed22c2a 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -16,7 +16,7 @@ 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,upsertCampusUserByCn,CampusUserConversionException()) +import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException()) import Handler.Utils import qualified Ldap.Client as Ldap @@ -31,23 +31,22 @@ postAdminLdapR = do let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList [])) procFormPerson lid = 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 -> do - ldapData <- campusUser'' ldapPool FailoverUnlimited lid - decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData - whenIsLeft decodedErr $ addMessageI Error - return ldapData + ldapPool' <- getsYesod $ view _appLdapPool + case ldapPool' of + Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing + Just ldapPool -> do + addMessage Info $ text2Html "Input for LDAP test received." + ldapData <- campusUser'' ldapPool campusUserFailoverMode lid + decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData + whenIsLeft decodedErr $ addMessageI Error + return ldapData mbLdapData <- formResultMaybe presult procFormPerson ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) - procFormUpsert lid = pure <$> runDB (try (upsertCampusUserByCn lid)) + procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) mbLdapUpsert <- formResultMaybe uresult procFormUpsert diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 7c81528ab..d97f2e8e5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -26,7 +26,7 @@ import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI -- import Auth.LDAP (ldapUserPrincipalName) -import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException()) +import Foundation.Yesod.Auth (ldapLookupAndUpsert, CampusUserConversionException()) import Handler.Utils.Company import Handler.Users.Add @@ -229,16 +229,13 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 -- | Always update AVS Data -upsertAvsUser :: Text -> Handler (Maybe UserId) +upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! -upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now - {- maybe this code helps? - upsRes :: Either CampusUserConversionException (Entity User) - <- try $ upsertCampusUserByOther persNo - case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid - _other -> return mbuid -- ==Nothing -- user could not be created somehow - -} +upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail + try (runDB $ ldapLookupAndUpsert otherId) >>= \case + Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now + _ -> return Nothing -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. @@ -279,7 +276,7 @@ upsertAvsUserById api = do (_:_) -> throwM AvsUserAmbiguous [] -> do upsRes :: Either CampusUserConversionException (Entity User) - <- try $ upsertCampusUserByCn persNo + <- try $ ldapLookupAndUpsert persNo $logInfoS "AVS" $ "No matching user found. attempted LDAP upsert returned: " <> tshow upsRes case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 9b20eaee7..0fddc70cf 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -86,8 +86,13 @@ newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) instance E.SqlString AvsInternalPersonalNo -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API + normalizeAvsInternalPersonalNo :: Text -> Text normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c) + +mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo +mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo + instance Canonical AvsInternalPersonalNo where canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn instance FromJSON AvsInternalPersonalNo where @@ -163,7 +168,7 @@ readAvsFullCardNo _ = Nothing discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) | Text.null pv - = Just $ Right $ AvsInternalPersonalNo c + = Just $ Right $ mkAvsInternalPersonalNo c | not $ Text.null c , Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 80bd07ac2..d1a82bb09 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -15,8 +15,8 @@ instance Arbitrary SloppyBool where shrink (SloppyBool x) = SloppyBool <$> shrink x instance Arbitrary AvsInternalPersonalNo where - arbitrary = canonical . AvsInternalPersonalNo <$> arbitrary - shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x + arbitrary = mkAvsInternalPersonalNo <$> arbitrary + shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x instance Arbitrary AvsPersonId where arbitrary = AvsPersonId <$> arbitrary