chore: make fetch and upsert results Maybe

src/Foundation/Yesod/Auth.hs

@@ -5,7 +5,7 @@
 module Foundation.Yesod.Auth
   ( authenticate
   , userLookupAndUpsert
-  , upsertUser
+  , upsertUser, maybeUpsertUser
   , decodeUserTest
   , DecodeUserException(..)
   , updateUserLanguage
@@ -22,7 +22,7 @@ import Foundation.Type
 import Foundation.Types
 import Foundation.I18n
 
-import Handler.Utils.Profile
+-- import Handler.Utils.Profile
 import Handler.Utils.LdapSystemFunctions
 import Handler.Utils.Memcached
 import Foundation.Authorization (AuthorizationCacheKey(..))
@@ -112,22 +112,12 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
   flip catches excHandlers $ if
     | not isDummy, not isOther
-    -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf
+    , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
-    , Just upsertMode' <- upsertMode -> do
+      Just userData -> do
-        userData <- fetchUserData Creds{..}
         $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
         Authenticated . entityKey <$> upsertUser upsertMode' userData
-        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
+      Nothing
-        -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..}
+        -> throwM FetchUserDataNoResult
-        -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData
-        -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..}
-    -- | not isDummy, not isOther
-    -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf
-    -- , Just upsertMode' <- upsertMode -> do
-    --     ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool
-    --     upsertUserLdapData <- ldapUser ldapPool Creds{..}
-    --     $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData
-    --     Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..}
     | otherwise
       -> acceptExisting
 
@@ -176,9 +166,9 @@ userLookupAndUpsert :: forall m.
                        )
                     => Text
                     -> UpsertUserMode
-                    -> SqlPersistT m (Entity User)
+                    -> SqlPersistT m (Maybe (Entity User))
 userLookupAndUpsert credsIdent mode =
-  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= upsertUser mode
+  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode
 
 
 data FetchUserDataException
@@ -197,23 +187,23 @@ fetchUserData :: forall m site.
                  , MonadUnliftIO m
                  )
               => Creds site
-              -> SqlPersistT m (NonEmpty UpsertUserData)
+              -> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
-fetchUserData creds@Creds{..} = do
+fetchUserData Creds{..} = do
   userAuthConf <- getsYesod $ view _appUserAuthConf
   now <- liftIO getCurrentTime
 
-  results :: NonEmpty UpsertUserData <- case userAuthConf of
+  results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
-    UserAuthConfSingleSource{..} -> (:| []) <$> case userAuthConfSingleSource of
+    UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
       AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
         queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
-          Right upsertUserAzureData -> return UpsertUserDataAzure{..}
+          Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
-          Left _ -> throwM FetchUserDataNoResult
+          Left _ -> return Nothing
-      AuthSourceConfLdap LdapConf{..} -> do
+      AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
-        ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool
+        Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
-        UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds
+        Nothing -> throwM FetchUserDataException
 
   -- insert ExternalUser entries for each fetched dataset
-  forM_ results $ \res ->
+  whenIsJust results $ \ress -> forM_ ress $ \res ->
     let externalUserUser =  error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId
         externalUserLastSync = now
         (externalUserData, externalUserSource) = case res of
@@ -225,15 +215,16 @@ fetchUserData creds@Creds{..} = do
 
 
 -- | Upsert User and related auth in DB according to given external source data (does not query source itself)
-upsertUser :: forall m.
+maybeUpsertUser :: forall m.
-              ( MonadHandler m
+                   ( MonadHandler m
-              , HandlerSite m ~ UniWorX
+                   , HandlerSite m ~ UniWorX
-              , MonadCatch m
+                   , MonadCatch m
-              )
+                   )
-           => UpsertUserMode
+                => UpsertUserMode
-           -> NonEmpty UpsertUserData
+                -> Maybe (NonEmpty UpsertUserData)
-           -> SqlPersistT m (Entity User)
+                -> SqlPersistT m (Maybe (Entity User))
-upsertUser _upsertMode upsertData = do
+maybeUpsertUser _upsertMode Nothing = return Nothing
+maybeUpsertUser _upsertMode (Just upsertData) = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
@@ -242,27 +233,10 @@ upsertUser _upsertMode upsertData = do
 
   oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  user@(Entity userId userRec) <- case oldUsers of
+  user@(Entity userId _userRec) <- case oldUsers of
     [oldUserId] -> updateGetEntity oldUserId userUpdate
     _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
 
-  -- sets display name
-  -- TODO: use display name from external source, if possible
-  unless (validDisplayName (newUser ^. _userTitle)
-                           (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname)
-                           (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
-
-  -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure)
-  -- when (validEmail' (userRec ^. _userEmail)) $ do
-  --   let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
-  --             ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-  --   unless (null emUps) $ update userId emUps
-  --   -- Attempt to update ident, too:
-  --   unless (validEmail' (userRec ^. _userIdent)) $
-  --     void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
-
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
     userSystemFunctions' = concat $ upsertData <&> \case
@@ -283,7 +257,19 @@ upsertUser _upsertMode upsertData = do
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return user
+  return $ Just user
+
+upsertUser :: forall m.
+              ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              , MonadCatch m
+              )
+           => UpsertUserMode
+           -> NonEmpty UpsertUserData
+           -> SqlPersistT m (Entity User)
+upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
+  Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
+  Just user -> return user
 
 
 decodeUser :: ( MonadThrow m

src/Handler/Admin/ExternalUser.hs

@@ -54,7 +54,7 @@ postAdminExternalUserR = do
   ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> 
     flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
   let procFormUpsert :: Text -> Handler (Maybe (Entity User))
-      procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser)
+      procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser)
 
   mbUpsert <- formResultMaybe uresult procFormUpsert
 

src/Handler/Utils/Avs.hs

@@ -355,9 +355,9 @@ guessAvsUser someid = do
             _              -> return Nothing
         uid -> return uid
     Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
-      Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> 
+      Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> 
         maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
-      Right Entity{entityKey=uid} -> return $ Just uid
+      Right (Just Entity{entityKey=uid}) -> return $ Just uid
       other -> do -- attempt to recover by trying other ids
         whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all      
         runDB . runMaybeT $ 
@@ -370,7 +370,7 @@ upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
 upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
   try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
-    Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
+    Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
     other -> do -- attempt to recover by trying other ids
       whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
       apid <- runDB . runMaybeT $ do
@@ -419,13 +419,16 @@ upsertAvsUserById api = do
               [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
-                upsRes :: Either SomeException (Entity User)
+                upsRes :: Either SomeException (Maybe (Entity User))
                   <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
                 $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
-                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right Nothing -> do
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases"
+                    return mbuid -- == Nothing -- user could not be created somehow
                   Left err -> do 
-                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err
                     return mbuid -- == Nothing -- user could not be created somehow
       (Just Entity{ entityKey = uaid }, _) -> do
         update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch

src/Handler/Utils/Users.hs

@@ -24,8 +24,7 @@ module Handler.Utils.Users
   ) where
 
 import Import
-import Auth.LDAP (ldapUserMatr')
+import Foundation.Yesod.Auth (userLookupAndUpsert)
-import Foundation.Yesod.Auth (upsertUser)
 
 import Crypto.Hash (hashlazy)
 
@@ -192,7 +191,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
       GuessUserSurname                userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
 
-    go didLdap = do
+    go didUpsert = do
       let retrieveUsers = E.select . EL.from $ \user -> do
             E.where_ . E.or $ map (E.and . map (toSql user)) criteria
             when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
@@ -234,12 +233,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | EQ <- x `closeness` x' = x : takeClosest (x':xs)
             | otherwise = [x]
 
-          -- TODO: Generalize
+          doUpsert = flip userLookupAndUpsert UpsertUserGuessUser
-          doLdap userMatr = do
-            ldapPool' <- getsYesod $ view _appLdapPool
-            fmap join . for ldapPool' $ \ldapPool@(LdapConf{ ldapConfSourceId = upsertUserLdapHost },_) -> do
-              ldapData <- ldapUserMatr' ldapPool userMatr
-              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser $ UpsertUserDataLdap{..} :| []
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
@@ -255,25 +249,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | otherwise                        = Nothing
           getTermMatrAux acc (_:xs) = getTermMatrAux acc xs
 
-        convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
+        convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
-        convertLdapResults []  = Nothing
+        convertUpsertResults []  = Nothing
-        convertLdapResults [x] = Just $ Right x
+        convertUpsertResults [x] = Just $ Right x
-        convertLdapResults xs  = Just $ Left $ NonEmpty.fromList xs
+        convertUpsertResults xs  = Just $ Left $ NonEmpty.fromList xs
 
       if
         | [x] <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Right x
         | x : x' : _ <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
         , GT <- x `closeness` x'
           -> return $ Just $ Right x
         | xs@(x:_:_) <- takeClosest users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Left $ NonEmpty.fromList xs
-        | not didLdap
+        | not didUpsert
         , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
-          -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
+          -> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes
         | otherwise
           -> return Nothing