fix(avs): several minor bugfixes

- See notes in #158 for details on update change policy
- fieldLensVal was not working
- create index for deleted table prevented start
- some hlint errors

src/Handler/Utils/Avs.hs

@@ -165,14 +165,6 @@ updateReceivers uid = do
 ------------------
 -- CR3 Functions
 
---
--- DONE Update UserCompany too
--- DONE #124 Add an old default supervisor to an Admin TODO-List          
--- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
--- DONE #36 "company postal preference", but for updates only yet
---
--- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
--- DONE: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
 
 -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
 class SomeAvsQuery q where 
@@ -291,31 +283,36 @@ data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => Chec
 -- | 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 -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdate ent newapi (Just oldapi) (CheckAvsUpdate up la)
+mkUpdate ent new (Just old) (CheckAvsUpdate up l)
-  | let newval = newapi ^. la
+  | let newval = new ^. l
-  , let oldval = oldapi ^. la
+  , let oldval = old ^. l
-  , let entval = getField up ent
+  , let entval = ent ^. fieldLensVal up
-  , oldval /= newval
+  , newval /= entval
   , oldval == entval
     = Just (up =. newval)
 mkUpdate _ _ _ _ = Nothing
 
+-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
+mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
+mkUpdate' ent new Nothing = mkUpdateDirect ent new
+mkUpdate' ent new just    = mkUpdate       ent new just
+
 mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdateDirect dbv inp (CheckAvsUpdate up l)
+mkUpdateDirect ent new (CheckAvsUpdate up l)
-  | let newval = inp ^. l
+  | let newval = new ^. l
-  , let entval = dbv ^. fieldLensVal up
+  , let entval = ent ^. 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) = 
+updateRecord ent new (CheckAvsUpdate up l) = 
-  let newval  = inp ^. l
+  let newval  = new ^. l
       lensRec = fieldLensVal up
-  in  dbv & lensRec .~ newval
+  in  ent & lensRec .~ newval
 
--- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism.
+-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism, but single query may throw
 updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
 updateAvsUserByIds apids0  = do    
     apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0
@@ -333,12 +330,12 @@ updateAvsUserByIds apids0  = do
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
-        newAvsCardNo <- queryAvsFullCardNo apid               -- Nothing os ok here
+        newAvsCardNo <- queryAvsFullCardNo apid               -- Nothing os ok here, does not throw
         now <- liftIO getCurrentTime
         let oldAvsPersonInfo = userAvsLastPersonInfo usravs   -- Nothing is ok here
             oldAvsFirmInfo   = userAvsLastFirmInfo   usravs   -- Nothing is ok here
             oldAvsCardNo     = userAvsLastCardNo     usravs & fmap Just
-            per_ups = mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo) -- NOTE: Updates erfolgen nur, wenn der Alt-Wert identisch zu Aktuellem-Wert sind! Bei mehreren Update-Möglichkeiten für ein Feld kann nur eines zutreffen.
+            per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
                       [ CheckAvsUpdate UserFirstName                _avsInfoFirstName
                       , CheckAvsUpdate UserSurname                  _avsInfoLastName
                       , CheckAvsUpdate UserDisplayName              _avsInfoDisplayName
@@ -347,14 +344,14 @@ updateAvsUserByIds apids0  = do
                       , CheckAvsUpdate UserMatrikelnummer         $ _avsInfoPersonNo . re _Just                                             -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
                       , CheckAvsUpdate UserCompanyPersonalNumber  $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just  -- Maybe im User und im AvsInfo
                       ]                    
-            em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo  $
+            em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo  $
                         CheckAvsUpdate UserDisplayEmail           $ _avsInfoPersonEMail  . to (fromMaybe mempty) . from _CI                 -- Maybe im AvsInfo, aber nicht im User
-            em_f_up = mkUpdate usr newAvsFirmInfo   oldAvsFirmInfo    $                                                                     -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
+            em_f_up = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo    $                                                                    -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
                         CheckAvsUpdate UserDisplayEmail           $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI
             eml_up  = em_p_up <|> em_f_up                                                                                                   -- ensure that only one email update is produced; there is no Eq instance for the Update type
-            frm_up  = mkUpdate usr newAvsFirmInfo   oldAvsFirmInfo    $                                                                     -- Legacy, if company postal is stored in user; should no longer be true for new users,
+            frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo    $                                                                    -- Legacy, if company postal is stored in user; should no longer be true for new users,
                         CheckAvsUpdate UserPostAddress _avsFirmPostAddress                                                                  -- since company address should now be referenced with UserCompany instead
-            pin_up  = mkUpdate usr newAvsCardNo     oldAvsCardNo      $                                                                     -- Maybe update PDF pin to latest card
+            pin_up  = mkUpdate' usr newAvsCardNo     oldAvsCardNo      $                                                                    -- Maybe update PDF pin to latest card
                         CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
             usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
             avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
@@ -371,6 +368,8 @@ updateAvsUserByIds apids0  = do
         let oldCompanyId = entityKey <$> oldCompanyEnt
             oldCompanyMb = entityVal <$> oldCompanyEnt
             pst_up  = if  
+                      -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
+                      --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
                       | isNothing oldCompanyMb 
                         -> mkUpdateDirect usr newCompany              $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
                       | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
@@ -550,7 +549,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
         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
         Entity firmid <$> updateGet firmid cmp_ups
         
   where
@@ -635,7 +634,7 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
                     UserId -> AvsLicence -> ReaderT backend m Bool
 setLicence uid lic = 
   getBy (UniqueUserAvsUser uid) >>= \case
-    Just (Entity{entityVal=UserAvs{userAvsPersonId=api}}) -> setLicenceAvs api lic
+    Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
     Nothing -> do
       uname <- userDisplayName <<$>> get uid      
       throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname

src/Model/Migration/Definitions.hs

@@ -95,8 +95,7 @@ migrateManual = do
     , ("idx_qualification_user_block_quser"  ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")")
     , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
     , ("idx_qualification_user_block_from"   ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")    
-    , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
+    , ("idx_print_job_apc_ident"             ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")    
-    , ("idx_user_avs_card_person_id"         ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
     , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
     , ("idx_user_company_company"            ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
     , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user    

src/Utils/DB.hs

@@ -45,8 +45,7 @@ fieldLensVal f = entityLens . fieldLens f
     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
+    setVal _ = entityVal    
-    setVal = const -- TODO verify
     
 
 emptyOrIn :: PersistField typ

test/Database/Fill.hs

@@ -769,7 +769,7 @@ fillDb = do
                 , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
   void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"   ) "123" False now Nothing Nothing now           Nothing    (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
   void . insert' $ LmsUser qid_f svaupel     (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1)     (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
-  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hiklmn") "@#!" True  now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
+  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hiklmn") "@#!" True  now (Just LmsBlocked) (Just   now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
   void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just LmsSuccess) (Just $ n_day' (-22))  (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
   void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11))  (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
   void . insert' $ LmsUser qid_f fhamann     (LmsIdent "123")  "456"    False now Nothing Nothing now Nothing Nothing Nothing False False

test/ModelSpec.hs

@@ -43,8 +43,8 @@ import Data.Universe
 
 instance Arbitrary EmailAddress where
     arbitrary = do
-      local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
+      local  <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
-      domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\d -> isEmail (CBS.pack "example") d)
+      domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (isEmail (CBS.pack "example"))
       let (Just result) = emailAddress (makeEmailLike local domain)
       pure result