fix(avs): company update checks uniques and ignores those updates if necessary

src/Handler/Utils/Avs.hs

@@ -565,16 +565,16 @@ getAvsCompany afi =
   in firstJustM $
       bcons (compAvsId > 0)
         ( getBy     $ UniqueCompanyAvsId  compAvsId    )
-        [ getEntity $ CompanyKey          compShorthand
+        [ getBy     $ UniqueCompanyName   compName
-        , getBy     $ UniqueCompanyName   compName
+        , getEntity $ CompanyKey          compShorthand
         ]
 
 -- | insert a company from AVS firm info or update an existing one based on previous values
 upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
-    mbFirmEnt <- getAvsCompany newAvsFirmInfo
+    mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
     case (mbFirmEnt, mbOldAvsFirmInfo) of
-      (Nothing, _) -> do                                                                                  -- insert new company
+      (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId, Shorthand or Name are known to exist
         let upd = flip updateRecord newAvsFirmInfo
             dmy = Company                                                                                 -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
                   { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
@@ -583,32 +583,36 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                   , companyPrefersPostal  = True
                   , companyPostAddress    = newAvsFirmInfo ^. _avsFirmPostAddress
                   , companyEmail          = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
-                  }
+                  }        
-        newCmp <- insertEntity $ foldl' upd dmy $ firmInfo2key : firmInfo2company
+        newCmp <- insertEntity $ foldl' upd dmy $ firmInfo2key : firmInfo2companyUniques <> firmInfo2company
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
         return newCmp
 
       (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
-        let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
+        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company            
-            key_ups =           mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
+            key_ups =            mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
-        res_cmp <- updateGetEntity firmid cmp_ups
+        uniq_ups <- maybeMapM   (mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2companyUniques
+        res_cmp <- updateGetEntity firmid $ cmp_ups <> uniq_ups
         case key_ups of 
           Nothing -> return res_cmp
           Just key_up -> do
-            let uniq_cmp = UniqueCompanyAvsId $ res_cmp ^. _entityVal . _companyAvsId
+            let compId   = res_cmp ^. _entityVal . _companyAvsId
+                uniq_cmp = if compId > 0  then UniqueCompanyAvsId compId
+                                          else UniqueCompanyName $ res_cmp ^. _entityVal . _companyName               
             updateBy uniq_cmp [key_up]                                                                    -- this is ok, since we have OnUpdateCascade on all CompanyId entries
             maybeM (return res_cmp) return $ getBy uniq_cmp
 
-
   where
-    firmInfo2key  = 
+    firmInfo2key = 
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
+    firmInfo2companyUniques =
+      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI  -- Updating unique turned out to be problematic, who would have thought!
+      , CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating unique turned out to be problematic, who would have thought!
+      ]
     firmInfo2company = 
-      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI      
+      [ CheckUpdate CompanyPostAddress   _avsFirmPostAddress
-      , CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating unique might be problematic
-      -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
-      , CheckUpdate CompanyPostAddress   _avsFirmPostAddress
       , CheckUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
+      -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
 

src/Utils/DB.hs

@@ -364,4 +364,28 @@ updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record ira
 updateRecord ent new (CheckUpdate up l) = 
   let newval  = new ^. l
       lensRec = fieldLensVal up
-  in  ent & lensRec .~ newval
+  in  ent & lensRec .~ newval
+
+-- | like mkUpdate' but only returns the update if the new value would be unique
+-- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
+
+mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) 
+                    => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))
+
+mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l)
+  | let newval = new ^. l
+  , let entval = ent ^. fieldLensVal up
+  , newval /= entval
+    = do 
+        newval_exists <- exists [up ==. newval]
+        return $ toMaybe (not newval_exists) (up =. newval)
+mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
+  | let newval = new ^. l
+  , let oldval = old ^. l
+  , let entval = ent ^. fieldLensVal up
+  , newval /= entval
+  , oldval == entval
+    = do 
+        newval_exists <- exists [up ==. newval]
+        return $ toMaybe (not newval_exists) (up =. newval)
+mkUpdateCheckUnique' _ _ _ _ = return Nothing