fix(avs): priority for picking primary email demote superior

src/Handler/Users.hs

@@ -494,7 +494,7 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''UserAssimilateButton id
 
 
-data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync
+data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync --  ThisUserHijack would make sense, but this 'btn' should not always be visible
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -521,6 +521,8 @@ postAdminUserR uuid = do
         n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
         addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
         redirectKeepGetParams $ AdminUserR uuid
+      -- ThisUserHijack -> do
+      --   redirect $ AdminHijackUserR uuid
     let thisUserActWgt = wrapForm thisUserActWgt' def 
           { formSubmit    = FormNoSubmit
           , formAction    = Just $ SomeRoute $ AdminUserR uuid

src/Handler/Utils/Avs.hs

@@ -323,14 +323,17 @@ updateAvsUserByIds' apids = do
 
 
 updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
-updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
+updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
       (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid      
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
-        let oldAvsPersonInfo = userAvsLastPersonInfo usravs   -- Nothing is ok here
+        let oldAvsPersonInfo  = userAvsLastPersonInfo usravs   -- Nothing is ok here
-            oldAvsFirmInfo   = userAvsLastFirmInfo   usravs   -- Nothing is ok here
+            oldAvsFirmInfo    = userAvsLastFirmInfo   usravs   -- Nothing is ok here
-            oldAvsCardNo     = userAvsLastCardNo     usravs & fmap Just
+            oldAvsCardNo      = userAvsLastCardNo     usravs & fmap Just
+            oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of 
+                                  (Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
+                                  _ -> Nothing
         newAvsCardNo <- queryAvsFullCardNo apid               -- Nothing os ok here, does not throw
         now <- liftIO getCurrentTime
         mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire
@@ -362,9 +365,7 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
                       , CU_API_UserMatrikelnummer       
                       -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
                       ]
-            eml_up =  let em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo  $ mkCheckUpdate CU_API_UserDisplayEmail 
+            eml_up =  mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail                            -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
-                          em_f_up = mkUpdate usr newAvsFirmInfo   oldAvsFirmInfo    $ mkCheckUpdate CU_AFI_UserDisplayEmail
-                      in  em_f_up <|> em_p_up                                                                                             -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.          
             frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo    $ mkCheckUpdate CU_AFI_UserPostAddress                             -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
             pin_up  = mkUpdate' usr newAvsCardNo     oldAvsCardNo      $                                                                  -- Maybe update PDF pin to latest card
                         CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just

src/Handler/Utils/AvsUpdate.hs

@@ -58,7 +58,7 @@ data CU_AvsPersonInfo_User
   | CU_API_UserMatrikelnummer       
   | CU_API_UserCompanyPersonalNumber
   | CU_API_UserLdapPrimaryKey       
-  | CU_API_UserDisplayEmail         
+  -- | CU_API_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead 
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_AvsPersonInfo_User where
@@ -72,25 +72,35 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where
   mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdate     UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
   mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate     UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
   mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdate     UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
+  -- mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
+data CU_AvsDataContcat_User
+  = CU_ADC_UserPostAddress
+  | CU_ADC_UserDisplayEmail
+  deriving (Show, Eq)
+
+instance MkCheckUpdate CU_AvsDataContcat_User where
+  type MCU_Rec CU_AvsDataContcat_User = User
+  type MCU_Raw CU_AvsDataContcat_User = AvsDataContact
+  mkCheckUpdate CU_ADC_UserPostAddress  = CheckUpdate    UserPostAddress    _avsContactPrimaryPostAddress
+  mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
 
 data CU_AvsFirmInfo_User
   = CU_AFI_UserPostAddress
-  | CU_AFI_UserDisplayEmail
+  -- | CU_AFI_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_AvsFirmInfo_User where
   type MCU_Rec CU_AvsFirmInfo_User = User
   type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
   mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdate     UserPostAddress             _avsFirmPostAddress
-  mkCheckUpdate CU_AFI_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
+  -- mkCheckUpdate CU_AFI_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
 
 
 -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
 data CU_UserAvs_User 
   = CU_UA_UserPinPassword          
-  | CU_UA_UserPostAddress          
+  -- | CU_UA_UserPostAddress          -- use _avsContactPrimaryPostAddress instead
   | CU_UA_UserFirstName            
   | CU_UA_UserSurname              
   | CU_UA_UserDisplayName          
@@ -99,14 +109,14 @@ data CU_UserAvs_User
   | CU_UA_UserMatrikelnummer       
   | CU_UA_UserCompanyPersonalNumber
   | CU_UA_UserLdapPrimaryKey       
-  | CU_UA_UserDisplayEmail         
+  -- | CU_UA_UserDisplayEmail         -- use _avsContactPrimaryEmailAddress instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_UserAvs_User where
   type MCU_Rec CU_UserAvs_User = User
   type MCU_Raw CU_UserAvs_User = UserAvs
   mkCheckUpdate CU_UA_UserPinPassword           = CheckUpdateOpt  UserPinPassword           $ _userAvsLastCardNo     . _Just . to avsFullCardNo2pin . re _Just
-  mkCheckUpdate CU_UA_UserPostAddress           = CheckUpdateOpt  UserPostAddress           $ _userAvsLastFirmInfo   . _Just . _avsFirmPostAddress
+  -- mkCheckUpdate CU_UA_UserPostAddress           = CheckUpdateOpt  UserPostAddress           $ _userAvsLastFirmInfo   . _Just . _avsFirmPostAddress  
   mkCheckUpdate CU_UA_UserFirstName             = CheckUpdateOpt  UserFirstName             $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName
   mkCheckUpdate CU_UA_UserSurname               = CheckUpdateOpt  UserSurname               $ _userAvsLastPersonInfo . _Just . _avsInfoLastName
   mkCheckUpdate CU_UA_UserDisplayName           = CheckUpdateOpt  UserDisplayName           $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName
@@ -115,4 +125,4 @@ instance MkCheckUpdate CU_UserAvs_User where
   mkCheckUpdate CU_UA_UserMatrikelnummer        = CheckUpdateOpt  UserMatrikelnummer        $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
   mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt  UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
   mkCheckUpdate CU_UA_UserLdapPrimaryKey        = CheckUpdateOpt  UserLdapPrimaryKey        $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  mkCheckUpdate CU_UA_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail  . _Just . from _CI
+  -- mkCheckUpdate CU_UA_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail  . _Just . from _CI

src/Model/Types/Avs.hs

@@ -641,6 +641,7 @@ makeLenses_ ''AvsFirmInfo
 -- additional convenience lenses:
 
 _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
+-- _avsFirmPostAddress :: Getter AvsFirmInfo (Maybe StoredMarkup)
 _avsFirmPostAddress = to mkPost
   where
     mkPost afi@AvsFirmInfo{avsFirmFirm} =
@@ -650,6 +651,7 @@ _avsFirmPostAddress = to mkPost
 
 -- | company post address without company name, better suited for comparisons
 _avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+-- _avsFirmPostAddressSimple :: Getter AvsFirmInfo (Maybe Text)
 _avsFirmPostAddressSimple = to mkPost
   where
     mkPost AvsFirmInfo{..} =
@@ -663,8 +665,8 @@ _avsFirmPrimaryEmail = to mkEmail
     mkEmail afi =
       let candidates =  catMaybes 
               [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
-              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email
               , afi ^. _avsFirmEMail
+              , afi ^. _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email              
               ]
       in pickValidEmail candidates -- should we return an invalid email rather than none?
 
@@ -721,6 +723,24 @@ data AvsDataContact = AvsDataContact
 
 makeLenses_ ''AvsDataContact
 
+_avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text)
+_avsContactPrimaryEmail = to mkEmail
+  where
+    mkEmail adc = 
+      let candidates = catMaybes
+            [ adc ^. _avsContactFirmInfo   . _avsFirmCommunication . _Just . _avsCommunicationEMail
+            , adc ^. _avsContactFirmInfo   . _avsFirmEMail
+            , adc ^. _avsContactPersonInfo . _avsInfoPersonEMail
+            , adc ^. _avsContactFirmInfo   . _avsFirmEMailSuperior   -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email      
+            ]
+      in pickValidEmail candidates -- should we return an invalid email rather than none?
+
+-- _avsContactPrimaryPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe StoredMarkup)
+-- _avsContactPrimaryPostAddress :: (Functor f, Contravariant f) => (Maybe StoredMarkup -> f (Maybe StoredMarkup)) -> AvsDataContact -> f AvsDataContact
+_avsContactPrimaryPostAddress :: Getter AvsDataContact (Maybe StoredMarkup)
+_avsContactPrimaryPostAddress = _avsContactFirmInfo . _avsFirmPostAddress
+
+
 -- instance Canonical AvsDataContact where
 --   canonical = over _avsContactPersonInfo canonical
 --             . over _avsContactFirmInfo   canonical