refactor(user): empty postal uses high priority company address instead (WIP)

models/users.model

@@ -14,7 +14,7 @@
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
-    displayEmail   UserEmail                -- Case-insensitive eMail address, used for sending
+    displayEmail   UserEmail                -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany
     email          UserEmail                -- Case-insensitive eMail address, used for identification and fallback for sending  TODO: make this nullable
     ident          UserIdent                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
@@ -45,8 +45,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP 
     companyDepartment     Text Maybe -- thus we store such information for ease of reference directly, if available 
     pinPassword           Text Maybe -- used to encrypt pins within emails
-    postAddress           StoredMarkup Maybe -- including company name, if any 
+    postAddress           StoredMarkup Maybe    -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany
-    postLastUpdate        UTCTime Maybe -- record postal address updates
+    postLastUpdate        UTCTime Maybe         -- record postal address updates    
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
@@ -91,6 +91,8 @@ UserCompany
     company               CompanyId  OnDeleteCascade OnUpdateCascade
     supervisor            Bool       default=false -- should this user be made supervisor for all _new_ users associated with this company?        
     supervisorReroute     Bool       default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
+    priority              Int        default=0     -- higher number, higher priority
+    useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress is used if UserPostalAddress is Nothing, respects priority
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
     deriving Generic
 UserSupervisor

src/Database/Esqueleto/Utils.hs

@@ -603,7 +603,7 @@ max, min :: PersistField a
 max a b = bool a b $ b E.>. a
 min a b = bool a b $ b E.<. a
 
--- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
+-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f
 greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
 greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
 

src/Handler/Utils/Avs.hs

@@ -17,7 +17,7 @@ module Handler.Utils.Avs
   , setLicence, setLicenceAvs, setLicencesAvs
   , retrieveDifferingLicences, retrieveDifferingLicencesStatus
   , computeDifferingLicences
-  , synchAvsLicences
+  -- , synchAvsLicences
   , lookupAvsUser, lookupAvsUsers
   , AvsException(..)
   , updateReceivers
@@ -45,6 +45,7 @@ import Handler.Utils.Company
 import Handler.Utils.Qualification
 import Handler.Utils.Memcached
 
+import           Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils        as E
@@ -76,259 +77,9 @@ instance Exception AvsException
 -}
 
 
-
-
 ------------------
 -- AVS Handlers --
 ------------------
-{-
-  TODOs
-    Connect AVS query to LDAP queries for automatic synchronisation:
-    - add query to Auth.LDAP.campusUserMatr
-    - add query to Auth.LDAP.campusLogin
-    - jobs.Handler.dispatchJobSynchroniseLdap
-
--}
-
-{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround
--- Do we need this?
--- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
-getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
-getLicence uid = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid
-  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
-  let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
-  return (avsLicenceRampLicence <$> ulicence)
-
-getLicenceDB :: UserId -> DB (Maybe AvsLicence)
-getLicenceDB uid = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
-  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
-  let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
-  return (avsLicenceRampLicence <$> ulicence)
-
-
--- | Should be avoided, since all licences must be requested at once.
-getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
-                      Set AvsPersonId -> m (Set AvsPersonLicence)
-getLicenceByAvsId aids = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences
-  return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences
--}
-
--- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
-setLicence :: (PersistUniqueRead backend, MonadThrow m,
-                     MonadHandler m, HandlerSite m ~ UniWorX,
-                     BaseBackend backend ~ SqlBackend) =>
-                    UserId -> AvsLicence -> ReaderT backend m Bool
-setLicence uid lic = do
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
-  setLicenceAvs userAvsPersonId lic
-
-setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
-                  AvsPersonId -> AvsLicence -> m Bool
-setLicenceAvs apid lic = do
-  let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
-  (1 ==) <$> setLicencesAvs req
-
-
---setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
-setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
-                  Set AvsPersonLicence -> m Int
-setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do
-    AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-    aux aqsl 0 persLics
-  where
-    aux aqsl batch0_ok pls
-      | Set.null pls = return batch0_ok
-      | otherwise = do
-        let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
-        response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1
-        case response of
-          AvsResponseSetLicencesError{..} -> do
-            let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
-            $logErrorS "AVS" msg
-            throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
-
-          AvsResponseSetLicences msgs -> do
-            let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
-                ok_ids = Set.map avsResponsePersonID ok
-                bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
-                batch1_ok = Set.size ok
-            forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
-              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-              -- TODO: Admin Error page
-            aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
-
-
--- | Retrieve all currently valid driving licences and check against our database
---   Only react to changes as compared to last seen status in avs.model
-synchAvsLicences :: Handler Bool
-synchAvsLicences = do
-  AvsQuery{..}  <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  allLicences   <- throwLeftM avsQueryGetAllLicences
-  deltaLicences <- computeDifferingLicences allLicences
-  setResponse   <- setLicencesAvs deltaLicences
-  let setOk = setResponse == Set.size deltaLicences
-  if setOk
-    then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
-    else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
-  return setOk
-
-data AvsLicenceDifferences = AvsLicenceDifferences
-    { avsLicenceDiffRevokeAll      :: Set AvsPersonId   -- revoke all driving licences in AVS (set 0)
-    , avsLicenceDiffGrantVorfeld   :: Set AvsPersonId   -- grant apron driving licence in AVS (set 1, upgrade from 0)
-    , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId   -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2)
-    , avsLicenceDiffGrantRollfeld  :: Set AvsPersonId   -- grant maneuvering area driving licence (set 2)
-    }
-  deriving (Show)
-
-#ifdef DEVELOPMENT
--- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
-#else
-avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
-avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions 
-  [ avsLicenceDiffRevokeAll     
-  , avsLicenceDiffGrantVorfeld  
-  , avsLicenceDiffRevokeRollfeld
-  , avsLicenceDiffGrantRollfeld 
-  ]
-#endif 
-
-avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
-avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
-     Set.map (AvsPersonLicence AvsNoLicence)       avsLicenceDiffRevokeAll
-  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffGrantVorfeld
-  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffRevokeRollfeld
-  <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
-
-computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
-computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
-
-type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
-
-avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
-avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
-
-retrieveDifferingLicences :: Handler AvsLicenceDifferences
-retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
-
-retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
-retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
-
-retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
-retrieveDifferingLicences' getStatus = do  
-#ifdef DEVELOPMENT
-  avsUsrs <- runDB $ selectList [] [LimitTo 444]
-  let allLicences = AvsResponseGetLicences $ Set.fromList $
-        [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
-        , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
-        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
-        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
-        -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
-        ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
-#else
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  allLicences  <- throwLeftM avsQueryGetAllLicences
-#endif
-  lDiff <- getDifferingLicences allLicences  
-#ifdef DEVELOPMENT
-  let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
-      lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
-      fakes = Set.fromList $ 
-              [ AvsStatusPerson (AvsPersonId 77      ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
-              , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True  AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True  AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
-              , AvsStatusPerson (AvsPersonId 5       ) $ Set.fromList [mkAdpc True  AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True  AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
-              , AvsStatusPerson (AvsPersonId 2       ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
-              ] <> 
-              [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
-#else
-  let statQry = avsLicenceDifferences2LicenceIds lDiff
-  lStat <- if getStatus && notNull statQry 
-            then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler
-              avsQueryStatus (AvsQueryStatus statQry) >>= \case 
-                Left err -> do
-                  addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
-                  return $ AvsResponseStatus mempty 
-                Right res -> return res
-            else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
-#endif
-  return (lDiff, avsResponseStatusMap lStat)
-
-  
-getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
-getDifferingLicences (AvsResponseGetLicences licences) = do
-  now <- liftIO getCurrentTime
-  --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
-  --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
-  -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
-  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
-      rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
-      vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
-      rollfeld       = Set.map avsLicencePersonID rollfeld'
-
-      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
-      antijoinAvsLicences lic avsLics = fmap unwrapIds $
-       E.select $ do
-        ((_qauli :& _qualUser :& usrAvs) :& excl) <-
-          E.from $ (      E.table @Qualification
-            `E.innerJoin` E.table @QualificationUser
-            `E.on` ( \(quali :& qualUser) ->
-                    (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
-                -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
-              E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
-              E.&&. (now `validQualification` qualUser)                                       -- currently valid and not blocked              
-              )
-            `E.innerJoin` E.table @UserAvs
-            `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
-          ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications
-            `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
-        E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId)           -- anti join
-        return (usrAvs E.?. UserAvsPersonId, excl)
-
-      unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
-      unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty
-        where
-          aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
-          aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
-          aux _ acc = acc -- should never occur
-
-  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
-    <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
-    <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
-  let setTo0      = vorfRevoke                    -- revoke driving licences 
-      setTo1up    = vorfGrant Set.\\ rollGrant    -- grant apron driving licence
-      setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence 
-      setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
-  return AvsLicenceDifferences
-    { avsLicenceDiffRevokeAll      = setTo0
-    , avsLicenceDiffGrantVorfeld   = setTo1up
-    , avsLicenceDiffRevokeRollfeld = setTo1down
-    , avsLicenceDiffGrantRollfeld  = setTo2
-    } 
-    {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
-        A (0,0,0)  -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
-        B (0,0,1)  -> ((_,_),(x,_)) : nop; do nothing     -- CHECK since id is returned by roll-query
-        C (0,1,0)  -> ((x,_),(_,_)) : set F for id
-        D (0,1,1)  -> ((x,_),(x,_)) : set R for id
-        E (1,0,0)  -> ((_,x),(_,_)) : set 0 for id
-        F (1,0,1)  -> ((_,x),(x,_)) : set 0 for id
-        G (1,1,0)  -> ((_,_),(_,_)) : nop
-        H (1,1,1)  -> ((_,_),(x,_)) : set R for id
-        I (2,0,0)  -> ((_,x),(_,x)) : set 0 for id
-        J (2,0,1)  -> ((_,x),(_,_)) : set 0 for id
-        K (2,1,0)  -> ((_,_),(_,x)) : set F for id
-        L (2,1,1)  -> ((_,_),(_,_)) : nop
-
-        PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
-        Results:
-            set to 0: determined by vorfeld-unset -- zuerst
-            set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
-            set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
-    -}
 
 -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users
 --   If an existing User with internal number is found, an AVS query is executed
@@ -719,7 +470,7 @@ updateAvsUserByIds apids = do
     let missing = Set.toList $ Set.difference apids $ Set.map fst res
     unless (null missing) $ do
       now <- liftIO getCurrentTime
-      updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"]
+      updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- TODO: last successfull synch
     return res
   where 
     procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do
@@ -738,7 +489,7 @@ updateAvsUserByIds apids = 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
                     ]
-          eml_up = let  -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo
+          eml_up = let  -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneously on AvsFirmInfo and AvsPersonInfo
                         eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail)
                         eml_new = (newAvsFirmInfo ^.         _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^.         _avsInfoPersonEMail)
                     in mkUpdate usr eml_new eml_old $
@@ -753,6 +504,7 @@ updateAvsUserByIds apids = do
                     , UserAvsLastPersonInfo =. Just newAvsPersonInfo
                     , UserAvsLastFirmInfo   =. Just newAvsFirmInfo
                     ]                                         
+      --                     
       lift $ do -- no more maybe here 
         update usrId usr_ups       
         oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo)
@@ -764,6 +516,11 @@ updateAvsUserByIds apids = do
         case oldAvsFirmInfo of 
           _ | oldCompanyId == Just newCompanyId                                               -- company unchanged entirely
               -> return ()
+          -- TODO: Update UserCompany too
+          -- TODO #124 Add an old default supervisor to an Admin TODO-List
+          -- Add function to use a secondary company post address that won't be updated
+          -- TODO #76 -- aktuelle Firmen löschen
+          -- TODO #36
           (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo        -- company address unchanged
               -> return ()
           (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo        -- company primary email unchanged
@@ -771,8 +528,8 @@ updateAvsUserByIds apids = do
           _                                                                                   -- company changed completely 
               -> do
                   let superReasonComDef = tshow SupervisorReasonCompanyDefault
-                      superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) oldCompanyId
+                      superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.)
-                  deleteWhere $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter, UserSupervisorReason ~=. superReasonComDef]         
+                  _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
                   E.insertSelectWithConflict
                     UniqueUserSupervisor
                     ( do 
@@ -787,10 +544,13 @@ updateAvsUserByIds apids = do
                           E.<&>  E.justVal superReasonComDef
                     )
                     (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
-                        [ UserSupervisorCompany E.=. E.coalesce [current  E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
+                        [ UserSupervisorCompany E.=. E.coalesce [current  E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
                         , UserSupervisorReason  E.=. E.coalesce [current  E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
                         ] 
                     )
+                  _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef]
+                  -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins                     
+                  -- TODO continue here
                   return ()
         update uaId  avs_ups
       return $ Set.singleton (apid, usrId)
@@ -843,3 +603,213 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       , CheckAvsUpdate CompanyPostAddress   _avsFirmPostAddress
       , CheckAvsUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
       ]
+
+
+-- Licences
+setLicence :: (PersistUniqueRead backend, MonadThrow m,
+                     MonadHandler m, HandlerSite m ~ UniWorX,
+                     BaseBackend backend ~ SqlBackend) =>
+                    UserId -> AvsLicence -> ReaderT backend m Bool
+setLicence uid lic = do
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
+  setLicenceAvs userAvsPersonId lic
+
+setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
+                  AvsPersonId -> AvsLicence -> m Bool
+setLicenceAvs apid lic = do
+  let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
+  (1 ==) <$> setLicencesAvs req
+
+
+--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
+setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
+                  Set AvsPersonLicence -> m Int
+setLicencesAvs = aux 0    
+  where
+    aux batch0_ok pls
+      | Set.null pls = return batch0_ok
+      | otherwise = do
+        let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
+        response <- avsQueryNoCache $ AvsQuerySetLicences batch1
+        case response of
+          AvsResponseSetLicencesError{..} -> do
+            let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
+            $logErrorS "AVS" msg
+            throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
+
+          AvsResponseSetLicences msgs -> do
+            let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
+                ok_ids = Set.map avsResponsePersonID ok
+                bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
+                batch1_ok = Set.size ok
+            forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
+              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
+              -- TODO: Admin Error page
+            aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
+
+{- NOT USED ANYWHERE:
+--   Retrieve all currently valid driving licences and check against our database
+--   Only react to changes as compared to last seen status in avs.model
+synchAvsLicences :: Handler Bool
+synchAvsLicences = do
+  allLicences   <- avsQueryNoCache AvsQueryGetAllLicences
+  deltaLicences <- computeDifferingLicences allLicences
+  setResponse   <- setLicencesAvs deltaLicences
+  let setOk = setResponse == Set.size deltaLicences
+  if setOk
+    then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
+    else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
+  return setOk
+-}
+
+
+data AvsLicenceDifferences = AvsLicenceDifferences
+    { avsLicenceDiffRevokeAll      :: Set AvsPersonId   -- revoke all driving licences in AVS (set 0)
+    , avsLicenceDiffGrantVorfeld   :: Set AvsPersonId   -- grant apron driving licence in AVS (set 1, upgrade from 0)
+    , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId   -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2)
+    , avsLicenceDiffGrantRollfeld  :: Set AvsPersonId   -- grant maneuvering area driving licence (set 2)
+    }
+  deriving (Show)
+
+#ifdef DEVELOPMENT
+-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
+#else
+avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
+avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions 
+  [ avsLicenceDiffRevokeAll     
+  , avsLicenceDiffGrantVorfeld  
+  , avsLicenceDiffRevokeRollfeld
+  , avsLicenceDiffGrantRollfeld 
+  ]
+#endif 
+
+avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
+avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
+     Set.map (AvsPersonLicence AvsNoLicence)       avsLicenceDiffRevokeAll
+  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffGrantVorfeld
+  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffRevokeRollfeld
+  <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld
+
+computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
+computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
+
+type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
+
+avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
+avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
+
+retrieveDifferingLicences :: Handler AvsLicenceDifferences
+retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
+
+retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
+retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
+
+retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
+retrieveDifferingLicences' getStatus = do  
+#ifdef DEVELOPMENT
+  avsUsrs <- runDB $ selectList [] [LimitTo 444]
+  let allLicences = AvsResponseGetLicences $ Set.fromList $
+        [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
+        , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
+        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
+        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
+        -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
+        ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
+#else  
+  allLicences  <- avsQuery AvsQueryGetAllLicences
+#endif
+  lDiff <- getDifferingLicences allLicences  
+#ifdef DEVELOPMENT
+  let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
+      lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
+      fakes = Set.fromList $ 
+              [ AvsStatusPerson (AvsPersonId 77      ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
+              , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True  AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True  AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
+              , AvsStatusPerson (AvsPersonId 5       ) $ Set.fromList [mkAdpc True  AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True  AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
+              , AvsStatusPerson (AvsPersonId 2       ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
+              ] <> 
+              [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
+#else
+  let statQry = avsLicenceDifferences2LicenceIds lDiff
+  lStat <- if getStatus && notNull statQry 
+            then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler
+              avsQueryStatus (AvsQueryStatus statQry) >>= \case 
+                Left err -> do
+                  addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
+                  return $ AvsResponseStatus mempty 
+                Right res -> return res
+            else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
+#endif
+  return (lDiff, avsResponseStatusMap lStat)
+
+  
+getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
+getDifferingLicences (AvsResponseGetLicences licences) = do
+  now <- liftIO getCurrentTime
+  --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
+  --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
+  -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
+  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences
+      rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
+      vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
+      rollfeld       = Set.map avsLicencePersonID rollfeld'
+
+      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
+      antijoinAvsLicences lic avsLics = fmap unwrapIds $
+       E.select $ do
+        ((_qauli :& _qualUser :& usrAvs) :& excl) <-
+          E.from $ (      E.table @Qualification
+            `E.innerJoin` E.table @QualificationUser
+            `E.on` ( \(quali :& qualUser) ->
+                    (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
+                -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
+              E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
+              E.&&. (now `validQualification` qualUser)                                       -- currently valid and not blocked              
+              )
+            `E.innerJoin` E.table @UserAvs
+            `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
+          ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications
+            `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
+        E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId)           -- anti join
+        return (usrAvs E.?. UserAvsPersonId, excl)
+
+      unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
+      unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty
+        where
+          aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
+          aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
+          aux _ acc = acc -- should never occur
+
+  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
+    <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
+    <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
+  let setTo0      = vorfRevoke                    -- revoke driving licences 
+      setTo1up    = vorfGrant Set.\\ rollGrant    -- grant apron driving licence
+      setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence 
+      setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
+  return AvsLicenceDifferences
+    { avsLicenceDiffRevokeAll      = setTo0
+    , avsLicenceDiffGrantVorfeld   = setTo1up
+    , avsLicenceDiffRevokeRollfeld = setTo1down
+    , avsLicenceDiffGrantRollfeld  = setTo2
+    } 
+    {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
+        A (0,0,0)  -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
+        B (0,0,1)  -> ((_,_),(x,_)) : nop; do nothing     -- CHECK since id is returned by roll-query
+        C (0,1,0)  -> ((x,_),(_,_)) : set F for id
+        D (0,1,1)  -> ((x,_),(x,_)) : set R for id
+        E (1,0,0)  -> ((_,x),(_,_)) : set 0 for id
+        F (1,0,1)  -> ((_,x),(x,_)) : set 0 for id
+        G (1,1,0)  -> ((_,_),(_,_)) : nop
+        H (1,1,1)  -> ((_,_),(x,_)) : set R for id
+        I (2,0,0)  -> ((_,x),(_,x)) : set 0 for id
+        J (2,0,1)  -> ((_,x),(_,_)) : set 0 for id
+        K (2,1,0)  -> ((_,_),(_,x)) : set F for id
+        L (2,1,1)  -> ((_,_),(_,_)) : nop
+
+        PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
+        Results:
+            set to 0: determined by vorfeld-unset -- zuerst
+            set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
+            set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
+    -}

src/Handler/Utils/Communication.hs

@@ -102,7 +102,7 @@ crJobsCourseCommunication jCourse Communication{..} = do
       adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails
   netReceiverAddresses <- lift $ do
     netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email
-    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] []
+    (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] -- TODO
   -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails
   let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails)
   forM_ jAllRecipientAddresses $ \raddr ->

src/Handler/Utils/Company.hs

@@ -19,7 +19,7 @@ oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- T
 oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do 
   cid <- oldUpsertCompany cName cAddr
   void $ upsertBy (UniqueUserCompany uid cid) 
-                  (UserCompany uid cid False False) 
+                  (UserCompany uid cid False False 0 False) 
                   []
   superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] []
   upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing

src/Handler/Utils/Mail.hs

@@ -16,7 +16,7 @@ import Import
 import Handler.Utils.Pandoc
 import Handler.Utils.Files
 import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
-import Handler.Utils.Users (getReceivers)
+import Handler.Utils.Users (getReceivers, getEmailAddress)
 import Handler.Utils.Profile 
 
 import qualified Data.CaseInsensitive as CI
@@ -46,6 +46,8 @@ userAddressFrom :: User -> Address
 -- Uses `userDisplayEmail` only
 userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
 
+
+-- TODO: Check that these functions can be used or are replaced, since they ignore company emails addresses
 userAddress :: User -> Address
 -- ^ Format an e-mail address suitable for usage as a recipient
 --
@@ -58,16 +60,19 @@ userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address
 userAddress' userEmail  userDisplayEmail userDisplayName
   = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail
 
-userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
+
-userAddressError User{userEmail, userDisplayEmail, userDisplayName} 
+userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX, m ~ HandlerFor UniWorX) => Entity User -> m (Bool, Address)
-  | Just okEmail <- pickValidUserEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
+userAddressError usr@Entity{entityVal=User{userEmail, userDisplayEmail, userDisplayName}} = 
-  | otherwise = do
+  runDB (getEmailAddress usr) >>= \case
+    Just okEmail -> pure (True, Address (Just userDisplayName) $ CI.original okEmail)
+    Nothing -> do
       $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject
       (False,) <$> getsYesod (view _appMailSupport)
 
 -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
+             , m ~ HandlerFor UniWorX
              , MonadThrow m
              , MonadUnliftIO m
              ) => UserId -> MailT m () -> m ()
@@ -84,7 +89,7 @@ userMailT uid mAct = do
                   <li>
                     #{nameHtml' svr}
           |]
-  forM_ receivers $ \Entity
+  forM_ receivers $ \svrEnt@Entity
       { entityKey = svr
       , entityVal = supervisor@User{ userLanguages
                                  , userDateTimeFormat
@@ -111,7 +116,7 @@ userMailT uid mAct = do
               $else
                 _{MsgMailSupervisorNoCopy}
           |]
-    (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise 
+    (mailOk, mailtoAddr) <- userAddressError svrEnt -- ensures a valid email, logs error and sends to support otherwise 
 
     mailT ctx $ do      
       _mailTo .= pure mailtoAddr 
@@ -126,6 +131,7 @@ userMailT uid mAct = do
 -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
 userMailTdirect :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
+             , m ~ HandlerFor UniWorX
              , MonadThrow m
              , MonadUnliftIO m
              ) => UserId -> MailT m a -> m a
@@ -138,6 +144,7 @@ userMailTdirect uid mAct = do
     , userCsvOptions
     } <- liftHandler . runDB $ getJust uid
   let
+    usrEnt = Entity {entityKey = uid, entityVal = user}
     ctx = MailContext
       { mcLanguages = fromMaybe def userLanguages
       , mcDateTimeFormat = \case
@@ -146,7 +153,7 @@ userMailTdirect uid mAct = do
           SelFormatTime -> userTimeFormat
       , mcCsvOptions = userCsvOptions
       }
-  (mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise 
+  (mailOk, mailtoAddr) <- userAddressError usrEnt -- ensures a valid email, logs error and sends to support otherwise 
   mailT ctx $ do
     -- failedSubject <- lookupMailHeader "Subject"
     -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)

src/Handler/Utils/Users.hs

@@ -15,7 +15,6 @@ module Handler.Utils.Users
   , guessUser
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
-  , userPrefersEmail, userPrefersLetter
   , getEmailAddress
   , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
@@ -67,36 +66,51 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
     assemble = Text.intercalate "."
 
 
--- deprecated, used getPostalPreferenceAndAddress
+-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
-userPrefersLetter :: User -> Bool
+getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail)
-userPrefersLetter = fst . getPostalPreferenceAndAddress
+getPostalPreferenceAndAddress usr = do
+  pa <- getPostalAddress usr
+  em <- getEmailAddress  usr
+  let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
+      finalPref   = (usrPrefPost && isJust pa) || isNothing em
+      -- finalPref   = isJust pa && (usrPrefPost || isNothing em)
+  return (finalPref, pa, em)
  
--- deprecated, used getPostalPreferenceAndAddress
-userPrefersEmail :: User -> Bool
-userPrefersEmail = not . userPrefersLetter
     
--- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
+getEmailAddress :: Entity User -> DB (Maybe UserEmail)
-getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
+getEmailAddress Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
-getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
+  | validEmail' userDisplayEmail
-    ((userPrefersPostal && postPossible) || not emailPossible, pa)
+    = return $ Just userDisplayEmail
-    -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
-  where        
-    pa = getPostalAddress usr
-    postPossible  = isJust pa
-    emailPossible = isJust $ getEmailAddress usr
-    
-getEmailAddress :: User -> Maybe UserEmail
-getEmailAddress User{userDisplayEmail, userEmail} = pickValidUserEmail' userDisplayEmail userEmail
-
-getPostalAddress :: User -> Maybe [Text]
-getPostalAddress User{..}
-  | Just pa <- userPostAddress
-    = Just $ userDisplayName : html2textlines pa
-  | Just abt <- userCompanyDepartment
-    = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
-                | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
   | otherwise
-    = Nothing
+    = do
+        compEmailMb <- runMaybeT $ do
+          Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority]
+          Company{companyEmail} <- MaybeT $ get cid
+          MaybeT $ return companyEmail
+        return $ pickValidEmail' $ mcons compEmailMb [userEmail]
+
+
+getPostalAddress :: Entity User -> DB (Maybe [Text])
+getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
+  | Just pa <- userPostAddress
+    = prefixMarkupName pa
+  | otherwise
+    = do
+        compAddrMb <- runMaybeT $ do
+          Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority]
+          Company{companyPostAddress} <- MaybeT $ get cid
+          MaybeT $ return companyPostAddress
+        case compAddrMb of
+          (Just pa)
+            -> prefixMarkupName pa
+          Nothing 
+            | Just abt <- userCompanyDepartment
+              -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
+                                    | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
+            | otherwise -> return Nothing
+  where 
+    prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
+
 
 -- | Consider using Handler.Utils.Avs.updateReceivers instead
 --   Return Entity User and all Supervisors with rerouteNotifications as well as
@@ -898,8 +912,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<&> (userCompany E.^. UserCompanyCompany)
         E.<&> (userCompany E.^. UserCompanySupervisor)
         E.<&> (userCompany E.^. UserCompanySupervisorReroute)
+        E.<&> (userCompany E.^. UserCompanyPriority)
+        E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
+    )
+    (\current excluded -> 
+      [ UserCompanySupervisor         E.=. E.greatest (current E.^. UserCompanySupervisor)        (excluded E.^. UserCompanySupervisor)       -- t > f
+      , UserCompanyPriority           E.=. E.greatest (current E.^. UserCompanyPriority)          (excluded E.^. UserCompanyPriority)
+      , UserCompanyUseCompanyAddress  E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
+      ]
     )
-    (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
   deleteWhere [ UserCompanyUser ==. oldUserId]
 
   mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId

src/Jobs/Handler/QueueNotification.hs

@@ -28,7 +28,7 @@ dispatchJobQueueNotification jNotification = JobHandlerAtomic $
   runConduit $ yield jNotification
             .| transPipe (hoist lift) determineNotificationCandidates
             .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> 
-                and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $
+                and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $ -- TODO: use getEmailAddress instead - although it is a DB action!
                   or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
             .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
             .| sinkDBJobs

src/Utils/Avs.hs

@@ -38,6 +38,9 @@ avsMaxSetLicenceAtOnce = 80   -- maximum input set size for avsQuerySetLicences
 avsMaxQueryAtOnce :: Int
 avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus as enforced by AVS
 
+avsMaxQueryDelay :: Int
+avsMaxQueryDelay = 300000    -- microsecond to wait before sending another AVS query
+
 
 avsApi :: Proxy AVS
 avsApi = Proxy
@@ -119,6 +122,7 @@ splitQuery rawQuery q
         --  logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
         let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
         res1 <-            rawQuery $ view _Unwrapped' avsid1
+        liftIO $ threadDelay avsMaxQueryDelay
         res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
         return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
   where 

src/Utils/Mail.hs

@@ -29,6 +29,9 @@ validEmail' = validEmail . CI.original
 pickValidEmail :: [Text] -> Maybe Text
 pickValidEmail = find validEmail
 
+-- | returns the first valid Email, if any
+pickValidEmail' :: [CI Text] -> Maybe (CI Text)
+pickValidEmail' = find validEmail' 
 
 -- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
 pickValidUserEmail :: CI Text -> CI Text -> CI Text

src/Utils/Print.hs

@@ -149,6 +149,12 @@ pdfLaTeX lk doc = do
 
 renderLetterPDF :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
 renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
+  rcvrPostal <- runDB $ getPostalAddress rcvrEnt
+  -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
+  renderLetterPDFto $ fromMaybe [rcvr & userDisplayName] rcvrPostal
+
+renderLetterPDFto :: (MDLetter l) => [Text] -> Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
+renderLetterPDFto rcvrPostal rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
   now <- liftIO getCurrentTime  
   formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr    
   let lang = selectDeEn $ rcvr & userLanguages   -- select either German or English only, default de; see Utils.Lang
@@ -160,8 +166,7 @@ renderLetterPDF rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
             [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
               toMeta "date"       $ format SelFormatDate now
             , toMeta "rcvr-name"  $ rcvr & userDisplayName
-            , toMeta "address"    $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
+            , toMeta "address"    $ rcvrPostal            
-            --, toMeta "rcvr-email"    $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
             ]
   e_md <- mdTemplating tmpl meta
   actRight e_md $ pdfLaTeX kind
@@ -171,6 +176,8 @@ renderLetterHtml :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either
 renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
     now <- liftIO getCurrentTime  
     formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
+    rcvrPostal <- runDB $ getPostalAddress rcvrEnt
+    -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
     let lang = selectDeEn $ rcvr & userLanguages   -- select either German or English only, default de; see Utils.Lang
         kind = getLetterKind        mdl
         tmpl = getTemplate          mdl
@@ -180,8 +187,8 @@ renderLetterHtml rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
               [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
                 toMeta "date"       $ format SelFormatDate now
               , toMeta "rcvr-name"  $ rcvr & userDisplayName
-              , toMeta "address"    $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
+              , toMeta "address"    $ fromMaybe [rcvr & userDisplayName] rcvrPostal
-              --, toMeta "rcvr-email"    $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
+              --, toMeta "rcvr-email"    $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise
               ]
     e_md <- mdTemplating tmpl meta
     actRight e_md $ \md -> pure . over _Left P.renderError . P.runPure $ do   
@@ -197,6 +204,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
   | Just l <- anyone mdls = do
       now <- liftIO getCurrentTime  
       formatter@DateTimeFormatter{ format } <- getDateTimeFormatterUser' rcvr
+      rcvrPostal <- runDB $ getPostalAddress rcvrEnt
+      -- (_,rcvrPostal, rcvrEmail) <- runDB $ getPostalPreferenceAndAddress
       let lang = selectDeEn $ rcvr & userLanguages   -- select either German or English only, default de; see Utils.Lang      
           kind = getLetterKind l
           
@@ -209,8 +218,8 @@ renderLetters rcvrEnt@Entity{entityVal=rcvr} mdls apcIdent
                           [ -- toMeta "lang" lang -- receiver language is decided in MDLetter instance, since some letters have fixed languages
                             toMeta "date"       $ format SelFormatDate now
                           , toMeta "rcvr-name"  $ rcvr & userDisplayName
-                          , toMeta "address"    $ fromMaybe [rcvr & userDisplayName] $ getPostalAddress rcvr
+                          , toMeta "address"    $ fromMaybe [rcvr & userDisplayName] rcvrPostal
-                          --, toMeta "rcvr-email"    $ rcvr & userDisplayEmail -- note that some templates use "email" already otherwise
+                          --, toMeta "rcvr-email"    $ fromMaybe [rcvr & userDisplayEmail] rcvrEmail -- note that some templates use "email" already otherwise                          
                           ]
             in mdTemplating tmpl meta <&> \case 
                 err@Left{} -> err
@@ -332,13 +341,14 @@ sendEmailOrLetter recipient letter = do
         mailSubject   = mkMailSubject isSupervised
     encRecipient :: CryptoUUIDUser <- encrypt svr
     apcIdent <- letterApcIdent letter encRecipient now
-    case getPostalPreferenceAndAddress rcvrUsr of 
+    postalPrefs <- getPostalPreferenceAndAddress rcvrEnt
-      (True, Nothing) -> do -- neither email nor postal is known
+    case postalPrefs of 
+      (_, Nothing, Nothing) -> do -- neither email nor postal is known
         let msg = "Notification failed for " <> tshow encRecipient <> ", who has neither a known email nor postal address. Notification: " <> tshow pjid
         $logErrorS "LETTER" msg
         return False
 
-      (True , Just _postal) -> renderLetterPDF rcvrEnt letter apcIdent >>= \case -- send printed letter
+      (True , Just postal, _) -> renderLetterPDFto postal rcvrEnt letter apcIdent >>= \case -- send printed letter
           Left err -> do -- pdf generation failed 
             let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid
             $logErrorS "LETTER" msg