refactor(avs): fix upsertCampusUserByCn

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 []))

src/Foundation/Yesod/Auth.hs

@@ -4,7 +4,8 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , upsertCampusUser, upsertCampusUserByCn 
+  , ldapLookupAndUpsert
+  , upsertCampusUser
   , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
@@ -107,9 +108,9 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
         _other -> return res
 
   $logDebugS "auth" $ tshow Creds{..}  
-  UniWorX{..} <- getYesod
+  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

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

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
+        ldapPool' <- getsYesod $ view _appLdapPool
-
+        case ldapPool' of 
-        if isNothing ldapPool'
+          Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
-          then addMessage Warning $ text2Html "LDAP Configuration missing."
+          Just ldapPool -> do 
-          else addMessage Info    $ text2Html "Input for LDAP test received."
+            addMessage Info  $ text2Html "Input for LDAP test received."
-        fmap join . for ldapPool' $ \ldapPool -> do
+            ldapData <- campusUser'' ldapPool campusUserFailoverMode lid                      
-          ldapData <- campusUser'' ldapPool FailoverUnlimited lid                      
+            decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
-          decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
+            whenIsLeft decodedErr $ addMessageI Error
-          whenIsLeft decodedErr $ addMessageI Error
+            return ldapData
-          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
 
 

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
+upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
-  {- maybe this code helps?
+  try (runDB $ ldapLookupAndUpsert otherId) >>= \case
-  upsRes :: Either CampusUserConversionException (Entity User)
+    Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
-    <- try $ upsertCampusUserByOther persNo
+    Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now  
-  case upsRes of
+    _ -> return Nothing
-    Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
-    _other -> return mbuid -- ==Nothing -- user could not be created somehow
-  -}
 
 
 -- | 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

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

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
+  arbitrary = mkAvsInternalPersonalNo <$> arbitrary
-  shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x
+  shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x
 
 instance Arbitrary AvsPersonId where 
   arbitrary = AvsPersonId <$> arbitrary