refactor(avs): company upsert done

updating supervision is still a todo

models/company.model

@@ -7,7 +7,7 @@
 Company  
   name            CompanyName             -- == (CI Text)
   shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId   A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
-  avsId           Int     default=0       -- primary key from avs
+  avsId           Int     default=0       -- primary key from avs, use negative numbers for non-AVS companies 
   prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
   postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
   email           UserEmail Maybe         -- Case-insensitive generic company eMail address
@@ -20,6 +20,6 @@ Company
 -- TODO: a way to populate this table (manually)
 CompanySynonym
   synonym     CompanyName
-  canonical   CompanyShorthand OnDeleteCascade OnUpdateCascade
+  canonical   CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId
   UniqueCompanySynonym synonym
   deriving Ord Eq Show Generic

models/users.model

@@ -97,7 +97,7 @@ UserSupervisor
     supervisor            UserId          -- multiple supervisor per trainee possible
     user                  UserId
     rerouteNotifications  Bool            -- User can be his own supervisor to receive notifications as well
-    company               CompanyId Maybe -- this supervisor was company default supervisor at time of entry
+    company               CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry
     reason                Text      Maybe -- miscellanoues reason, e.g. Winterservice supervisision
     UniqueUserSupervisor supervisor user  -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
     deriving Generic

src/Foundation/Yesod/Auth.hs

@@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
   (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
-  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
+  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
   oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
 

src/Handler/Utils/Avs.hs

@@ -51,6 +51,8 @@ import qualified Database.Esqueleto.Utils        as E
 
 import Servant.Client.Core.ClientError (ClientError)
 
+import Utils.Mail (pickValidEmail)
+import Handler.Utils.Profile (validPostAddressText)
 
 
 --------------------
@@ -472,7 +474,7 @@ upsertAvsUserById api = do
         -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
         -- forM_ cs $  -- only save used cards for the postal address update detection
             \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now
-        upsertUserCompany uid mbCompany userFirmAddr
+        oldUpsertUserCompany uid mbCompany userFirmAddr
       return mbUid
 
     (Just (Entity _ UserAvs{userAvsUser=uid})
@@ -500,7 +502,7 @@ upsertAvsUserById api = do
             updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged
                         [UserPinPassword =. userPin]
             insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
-        upsertUserCompany uid mbCompany userFirmAddr
+        oldUpsertUserCompany uid mbCompany userFirmAddr
         forM_ avsPersonPersonCards $ \aCard -> do
           let fcn = getFullCardNo aCard
           -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
@@ -640,21 +642,66 @@ queryAvsCardNo crd = do
                                        }
 
 
+_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
+_avsFirmPostAddress = to mkPost
+  where
+    mkPost AvsFirmInfo{..} =
+        let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
+            commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
+            someAddr = fromMaybe "" $ asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
+        in if null someAddr 
+            then Nothing
+            else Just $ plaintextToStoredMarkup $ avsFirmFirm <> Text.cons '\n' someAddr
+
+_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+_avsFirmPrimaryEmail = to mkEmail
+  where
+    mkEmail afi =
+      let candidates =  catMaybes 
+              [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
+              , afi ^. _avsFirmEMailSuperior
+              , afi ^. _avsFirmEMail
+              ]
+      in pickValidEmail candidates -- should we return an invalid email rather than none?
+
+-- | Not sure this is useful, since postal is ignored if there is no post address anyway
+_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
+_avsFirmPrefersPostal = to mkPostPref
+  where 
+    mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
+
+
+
 -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
 data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
 
 -- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
 --   an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
 mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdate usr newapi oldapi (CheckAvsUpdate up la)
+mkUpdate ent newapi oldapi (CheckAvsUpdate up la)
   | let newval = newapi ^. la
   , let oldval = oldapi ^. la
-  , let usrval = getField up usr
+  , let entval = getField up ent
   , oldval /= newval
-  , oldval == usrval
+  , oldval == entval
     = Just (up =. newval)
 mkUpdate _ _ _ _ = Nothing
 
+mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
+mkUpdateDirect dbv inp (CheckAvsUpdate up l)
+  | let newval = inp ^. l
+  , let entval = dbv ^. fieldLensVal up
+  , newval /= entval
+    = Just (up =. newval)
+mkUpdateDirect _ _ _ = Nothing
+
+-- | Unconditionally update a record through CheckAvsU
+updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
+updateRecord dbv inp (CheckAvsUpdate up l) = 
+  let newval  = inp ^. l
+      lensRec = fieldLensVal up
+  in  dbv & lensRec .~ newval
+
 
 -- | Update given AvsPersonId by querying AVS for each; update only, no insertion!
 updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
@@ -693,20 +740,62 @@ updateAvsUserByIds apids = do
                     [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup)
                     ]
           usr_ups = mcons eml_up $ frm_ups <> per_ups
-          -- TODO: update Company
-          -- cmp_up = let
-          --            cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
-          --            cno_new = (oldAvsFirmInfo ^.         _avsFirmFirmNo)
-          --           in 
-          --               cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm  )
-          --               cmp_new = (oldAvsFirmInfo ^.         _avsFirmFirm  )
-
           avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
                     [ UserAvsLastSynch      =. now
                     , UserAvsLastSynchError =. Nothing
                     , UserAvsLastPersonInfo =. Just newAvsPersonInfo
                     , UserAvsLastFirmInfo   =. Just newAvsFirmInfo
-                    ]                     
+                    ]                                         
-      lift $ update usrId usr_ups 
+      _newCompanyId <- lift $ upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+      -- TODO: if the company id has changed, update supervision too
+      lift $ update usrId usr_ups       
       lift $ update uaId  avs_ups
       return $ Set.singleton (apid, usrId)
+
+-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked
+getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
+getAvsCompany afi = 
+  let compName :: CompanyName
+      compName       = afi ^. _avsFirmFirm . re _CI
+      compShorthand :: CompanyShorthand
+      compShorthand  = afi ^. _avsFirmAbbreviation . re _CI
+      compAvsId      = afi ^. _avsFirmFirmNo
+  in firstJustM 
+      [ getBy     $ UniqueCompanyAvsId  compAvsId
+      , getEntity $ CompanyKey          compShorthand
+      , getBy     $ UniqueCompanyName   compName
+      ]
+
+upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB CompanyId
+upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
+    mbFirmEnt <- getAvsCompany newAvsFirmInfo
+    case (mbFirmEnt, mbOldAvsFirmInfo) of
+      (Nothing, _) -> do                                                                                  -- insert new company
+        let upd = flip updateRecord newAvsFirmInfo
+            dmy = Company
+                  { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . re _CI
+                  , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . re _CI
+                  , companyAvsId          = newAvsFirmInfo ^. _avsFirmFirmNo
+                  , companyPrefersPostal  = True
+                  , companyPostAddress    = Nothing
+                  , companyEmail          = Nothing
+                  }
+        insert $ foldl' upd dmy firmInfo2company
+
+      (Just Entity{entityKey=firmid                }, Nothing) -> do                                      -- neither insert nor update; update impossible without old comparison values, since company could have been edited
+        $logWarnS "AVS" $ "upsertAvsCompany: neither insert nor update. Received existing company " <> (newAvsFirmInfo ^. _avsFirmFirm) <> " without old comparison value for update."
+        return firmid
+
+      (Just Entity{entityKey=firmid, entityVal=firm}, Just oldAvsFirmInfo) -> do                          -- possibly update existing company
+        let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
+        update firmid cmp_ups
+        return firmid 
+  where
+    firmInfo2company = 
+      [ CheckAvsUpdate CompanyName        $ _avsFirmFirm          . re _CI
+      , CheckAvsUpdate CompanyShorthand   $ _avsFirmAbbreviation  . re _CI
+      , CheckAvsUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
+      -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
+      , CheckAvsUpdate CompanyPostAddress   _avsFirmPostAddress
+      , CheckAvsUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
+      ]

src/Handler/Utils/Company.hs

@@ -15,9 +15,9 @@ import qualified Data.Text as Text
 import Database.Persist.Postgresql
 
 -- | Ensure that the given user is linked to the given company
-upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
+oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
-upsertUserCompany uid (Just cName) cAddr | notNull cName = do 
+oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do 
-  cid <- upsertCompany cName cAddr
+  cid <- oldUpsertCompany cName cAddr
   void $ upsertBy (UniqueUserCompany uid cid) 
                   (UserCompany uid cid False False) 
                   []
@@ -25,20 +25,20 @@ upsertUserCompany uid (Just cName) cAddr | notNull cName = do
   upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing
                   | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs
                   ] [] [] []
-upsertUserCompany uid _ _ = 
+oldUpsertUserCompany uid _ _ = 
   deleteWhere [ UserCompanyUser ==. uid ]     -- maybe also delete company supervisors?
 
 -- | Does not update company address for now
 -- TODO: update company address, maybe?!
-upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
+oldUpsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
-upsertCompany cName cAddr = 
+oldUpsertCompany cName cAddr = 
   let cName' = CI.mk cName in
   getBy (UniqueCompanyName cName') >>= \case 
     Just ent -> return $ entityKey ent
     Nothing  -> getBy (UniqueCompanySynonym cName') >>= \case
       Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
       Nothing  -> do
-        let cShort  = companyShorthandFromName cName            
+        let cShort  = oldCompanyShorthandFromName cName            
         cShort' <- findShort cName' $ CI.mk cShort
         let compy  = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented
         either entityKey id <$> insertBy compy
@@ -52,8 +52,8 @@ upsertCompany cName cAddr =
                   _other  -> aux (n+1)
 
 -- | Just a cheap heuristic, needs manual intervention anyway
-companyShorthandFromName :: Text -> Text
+oldCompanyShorthandFromName :: Text -> Text
-companyShorthandFromName cName = 
+oldCompanyShorthandFromName cName = 
   let cpats = splitCamel cName
       strip = Text.filter Char.isAlphaNum . Text.take 3
       spats = strip <$> cpats

src/Handler/Utils/Profile.hs

@@ -7,7 +7,7 @@
 module Handler.Utils.Profile
   ( module Utils.Mail
   , validDisplayName, checkDisplayName, fixDisplayName
-  , validPostAddress    
+  , validPostAddress, validPostAddressText
   , validFraportPersonalNumber
   ) where
 
@@ -66,14 +66,20 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
 
 -- | Primitive postal address requires at least one alphabetic character, one digit and a line break
 validPostAddress :: Maybe StoredMarkup -> Bool
-validPostAddress (Just StoredMarkup {markupInput = addr})
+validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
-  | Just _ <- LT.find isLetter addr
-  , Just _ <- LT.find isNumber addr 
-  -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
-  , 1 < length (LT.lines addr) 
-    = True
 validPostAddress _ = False
 
+validPostAddressText :: Text -> Bool
+validPostAddressText = validPostAddressLazyText . LT.fromStrict
+
+validPostAddressLazyText :: LT.Text -> Bool
+validPostAddressLazyText addr
+  | Just _ <- LT.find isLetter addr
+  , Just _ <- LT.find isNumber addr
+  -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
+    = 1 < length (LT.lines addr)    
+validPostAddressLazyText _ = False
+
 validFraportPersonalNumber :: Maybe Text -> Bool
 validFraportPersonalNumber Nothing = False
 validFraportPersonalNumber (Just t)

src/Model/Types/Avs.hs

@@ -27,7 +27,6 @@ import qualified Data.Set           as Set
 import Data.Aeson
 import Data.Aeson.Types
 
-import Utils.Mail
 
 {-
 -- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
@@ -602,7 +601,7 @@ derivePersistFieldJSON ''AvsFirmCommunication
 
 data AvsFirmInfo = AvsFirmInfo
   { avsFirmFirm             :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
-  , avsFirmFirmNo           :: Int
+  , avsFirmFirmNo           :: Int  -- bei Verwendung ohne AVS: negative Zahl einsetzen
   , avsFirmAbbreviation     :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
   , avsFirmZIPCode          :: Maybe Text
   , avsFirmCity             :: Maybe Text
@@ -624,16 +623,11 @@ _avsFirmAddress = to mkAddr
           commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
       in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr]
 
-_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+-- Necessarily Moved to Handler.Utils.Avs due to dependencies: 
-_avsFirmPrimaryEmail = to mkEmail
+-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) 
-  where
+-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
-    mkEmail afi =
+-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
-      let candidates =  catMaybes 
+
-              [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
-              , afi ^. _avsFirmEMailSuperior
-              , afi ^. _avsFirmEMail
-              ]
-      in pickValidEmail candidates -- should we return an invalid email rather than none?
 
 instance FromJSON AvsFirmInfo where
   parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo

src/Utils.hs

@@ -1017,18 +1017,22 @@ forMaybeM :: ( Monad m
              ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
 forMaybeM = flip mapMaybeM
 
-{-
+-- | Only execute second action if the first does not produce a result
---   Takes computations returnings @Maybes@; tries each one in order.
+altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
+altM ma mb = ma >>= \case 
+  Nothing -> mb
+  res     -> return res
+
+--   Takes computations returnings @Maybe@; tries each one in order.
 --   The first one to return a @Just@ wins. Returns @Nothing@ if all computations
 --   return @Nothing@.
 --   Copied from GHC.Data.Maybe, which could not be imported somehow.
-firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
+firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
-firstJustsM = foldlM go Nothing 
+firstJustM = foldlM go Nothing 
   where
     go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
     go Nothing          action = action
     go result@(Just _) _action = return result
--}
 
 -- | Run the maybe computation repeatedly until the first Just is returned
 --   or the number of maximum retries is exhausted.

src/Utils/DB.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -34,8 +34,18 @@ getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -
 getFieldEnt = view . fieldLens
 
 getField :: PersistEntity record => EntityField record typ -> record -> typ
-getField = (. Entity (error "getField required key")) . getFieldEnt
+getField = view . fieldLensVal
 
+fieldLensVal :: PersistEntity record => EntityField record field -> Lens' record field
+fieldLensVal f = entityLens . fieldLens f
+  where 
+    entityLens :: Lens' record (Entity record)
+    entityLens = lens getVal setVal
+    getVal :: record -> Entity record
+    getVal   = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
+    setVal :: record -> Entity record -> record
+    setVal _ = entityVal
+    
 
 emptyOrIn :: PersistField typ
           => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)