chore(AVS): implement user avs update to primary company as outlined in graph in wiki

messages/uniworx/categories/admin/de-de-formal.msg

@@ -129,6 +129,7 @@ AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markier
 AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet
 AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
 AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
+AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren
 ProblemTableMarkUnsolved: Erledigt Markierung löschen

messages/uniworx/categories/admin/en-eu.msg

@@ -129,6 +129,7 @@ AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
 AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
 AdminProblemNewCompany: New company from AVS; verify and add default supervisors
 AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
+AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
 AdminProblemUser: Affected
 ProblemTableMarkSolved: Mark done
 ProblemTableMarkUnsolved: Reopen as undone

src/Audit/Types.hs

@@ -260,16 +260,21 @@ derivePersistFieldJSON ''Transaction
 
 -- Datatype for raising admin awareness to certain problems
 -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
-
+-- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell
 data AdminProblem
   = AdminProblemNewCompany                                      -- new company was noticed, presumably without supervisors
     { adminProblemCompany           :: CompanyId
     }
   | AdminProblemSupervisorNewCompany                            
-    { adminProblemUser              :: UserId                         -- a default supervisor has changed company
+    { adminProblemUser              :: UserId                   -- a default supervisor has changed company
-    , adminProblemCompany           :: CompanyId                      -- old company where the user had default supervisor rights
+    , adminProblemCompany           :: CompanyId                -- old company where the user had default supervisor rights
-    , adminProblemCompanyNew        :: CompanyId                      -- new company of the user
+    , adminProblemCompanyNew        :: CompanyId                -- new company of the user
-    , adminProblemSupervisorReroute :: Bool                           -- reroute included?
+    , adminProblemSupervisorReroute :: Bool                     -- reroute included?
+    }
+  | AdminProblemNewlyUnsupervised  
+    { adminProblemUser              :: UserId                   -- user who had supervsior but no longer has
+    , adminProblemCompanyOld        :: Maybe CompanyId          -- old company
+    , adminProblemCompanyNew        :: CompanyId                -- new company of the user
     }
   | AdminProblemUnknown                                         -- miscellanous problem, just displaying text
     { adminProblemText              :: Text    

src/Handler/Admin.hs

@@ -323,7 +323,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
       , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
       , sortable (Just "info")    (i18nCell MsgAdminProblemInfo)    $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
-      , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
+      -- , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
+      , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
       , sortable (Just "user")    (i18nCell MsgAdminProblemUser)    $ \(preview resultUser   -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "solved")  (i18nCell MsgAdminProblemSolved)  $ \(   view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
       , sortable (Just "solver")  (i18nCell MsgAdminProblemSolver)  $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
@@ -375,9 +376,12 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
       return (act, usrSet)
 
 adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
+-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
 adminProblemCell AdminProblemNewCompany{}                                 
   = i18nCell MsgAdminProblemNewCompany
 adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
+adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}  
+  = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemUnknown{adminProblemText}  
   = textCell $ "Problem: " <> adminProblemText

src/Handler/Utils/Avs.hs

@@ -498,7 +498,7 @@ updateAvsUserByIds apids = do
           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,
                       CheckAvsUpdate UserPostAddress _avsFirmPostAddress                                                                  -- since company address should now be referenced with UserCompany instead          
-          usr_up0 = eml_up `mcons` (frm_up `mcons` per_ups)
+          usr_up1 = eml_up `mcons` (frm_up `mcons` per_ups)
           avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
                     [ UserAvsLastSynch      =. now
                     , UserAvsLastSynchError =. Nothing
@@ -511,52 +511,57 @@ updateAvsUserByIds apids = do
       -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
       -- TODO #36 "company postal preference"
       --
-      lift $ do -- no more maybeT neeed from here 
+      lift $ do -- maybeT no longer needed from here onwards
         -- update company association & supervision
         Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
         oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
+        primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand)
         let oldCompanyId = entityKey <$> oldCompanyEnt
             oldCompanyMb = entityVal <$> oldCompanyEnt
-            pst_up  = mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+            pst_up  = if  
+                      | isJust oldCompanyId && (oldCompanyId == primaryCompanyId)
+                        -> mkUpdate       usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+                      | isNothing oldCompanyMb 
+                        -> mkUpdateDirect usr newCompany              $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+                      | otherwise
+                        -> Nothing
             superReasonComDef = tshow SupervisorReasonCompanyDefault
             newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
-        primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand)
         
-        usr_ups <- case oldAvsFirmInfo of 
+
+        usr_up2 <- case oldAvsFirmInfo of 
           _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
-              -> return usr_up0                                                               --  => do nothing
+              -> return Nothing                                                               --  => do nothing
           (Just oafi) |  ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- company address unchanged OR
                       || ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- company primary email unchanged
               -> do                                                                           --  => just update user company association, keeping supervision privileges                  
                   case oldCompanyId of
                     Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
                     Just ocid -> do 
-                      void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)
+                      void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
-                      void $ updateWhere [ UserSupervisorSupervisor ==. usrId
+                      void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
-                                         , UserSupervisorCompany ==. Just ocid
+                                         , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of 
-                                         , UserSupervisorReason ==. Just superReasonComDef] -- to we want this last condition?
+                                         , UserSupervisorReason ==. Just superReasonComDef]                                 -- user 
                                          [ UserSupervisorCompany =. Just newCompanyId]
-                  return usr_up0
+                  return Nothing                  
-          _ | Just newCompanyId == primaryCompanyId -- Wechsel der AVS-Firma zur FRADrive-Primärfirma
+          _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
               -> do
-                  whenIsJust oldCompanyId $ deleteBy . UniqueUserCompany usrId
+                  whenIsJust oldCompanyId $ \oldCid -> do 
-                  when (isJust oldCompanyId) $ deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
+                    deleteBy $ UniqueUserCompany usrId oldCid
-                  return usr_up0
+                    deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
+                  return Nothing
           _                                                                                   -- company changed completely 
-              -> do -- switch company, keeping priority
+              -> do 
+                  -- switch user company, keeping old priority
                   (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
-                    Nothing -> do 
+                    Nothing ->
                       void $ insertUnique newUserComp
                     Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
                       when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
                       delete ucidOld
-                      void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True
+                      void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-                  
+                  -- adjust supervison                                                           
-                  -- forMM_ (get newCompanyId) $ \Company{} ->
+                  oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-                  --   void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults
-
-                  let superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.)
-                  _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
                   E.insertSelectWithConflict
                     UniqueUserSupervisor
                     ( do 
@@ -575,10 +580,9 @@ updateAvsUserByIds apids = do
                         , UserSupervisorReason  E.=. E.coalesce [current  E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
                         ] 
                     )
-                  _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef]
+                  newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-                  -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins                     
+                  when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-                  -- TODO continue here
+                  return pst_up 
-                  return $ pst_up `mcons` usr_up0
         -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
         whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
           (altM (guessUserByEmail $ supemail ^. from _CI)
@@ -588,7 +592,7 @@ updateAvsUserByIds apids = do
             deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
             void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior
         -- update stored avsinfo
-        update usrId usr_ups
+        update usrId $ usr_up2 `mcons` usr_up1
         update uaId  avs_ups
       return $ Set.singleton (apid, usrId)
 

src/Utils/Persist.hs

@@ -5,7 +5,7 @@
 module Utils.Persist
   ( fromPersistValueError
   , fromPersistValueErrorSql
-  , (~=.)
+  , (~=.), (~~.)
   ) where
 
 import ClassyPrelude
@@ -41,6 +41,12 @@ fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $
 
 
 infix 4 ~=.
--- | is Equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries
+-- | is equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries
 (~=.) :: PersistField a =>  EntityField v (Maybe a) -> a -> [Filter v]
-(~=.) f v = [f ==. Just v] ||. [f ==. Nothing]
+(~=.) f v         = [f ==. Nothing] ||. [f ==. Just v]
+
+infix 4 ~~.
+-- | maybe is equal or Nothing,
+(~~.) :: PersistField a =>  EntityField v (Maybe a) -> Maybe a -> [Filter v]
+(~~.) f Nothing   = [f ==. Nothing]
+(~~.) f (Just v)  = [f ==. Nothing] ||. [f ==. Just v]

src/Utils/TH.hs

@@ -167,6 +167,7 @@ embedRenderMessage f inner mangle = do
       ]
     ]
 
+-- ^ Like @embedRenderMessage, but for newtype definitions
 embedRenderMessageVariant :: Name -- ^ Foundation Type
                           -> Name -- ^ Name of newtype
                           -> (Text -> Text) -- ^ Mangle constructor names