diff --git a/models/company.model b/models/company.model index 422a7a14d..6986b1af6 100644 --- a/models/company.model +++ b/models/company.model @@ -7,7 +7,7 @@ Company name CompanyName -- == (CI Text) shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness - avsId Int default=0 -- primary key from avs + avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies prefersPostal Bool default=false -- new company users prefers letters by post instead of email postAddress StoredMarkup Maybe -- default company postal address, including company name email UserEmail Maybe -- Case-insensitive generic company eMail address @@ -20,6 +20,6 @@ Company -- TODO: a way to populate this table (manually) CompanySynonym synonym CompanyName - canonical CompanyShorthand OnDeleteCascade OnUpdateCascade + canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId UniqueCompanySynonym synonym deriving Ord Eq Show Generic diff --git a/models/users.model b/models/users.model index ad7b20c00..05741d3b6 100644 --- a/models/users.model +++ b/models/users.model @@ -97,7 +97,7 @@ UserSupervisor supervisor UserId -- multiple supervisor per trainee possible user UserId rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well - company CompanyId Maybe -- this supervisor was company default supervisor at time of entry + company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry reason Text Maybe -- miscellanoues reason, e.g. Winterservice supervisision UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) deriving Generic diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index efabadc80..9e9aa85c6 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do userDefaultConf <- getsYesod $ view _appUserDefaults (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData - --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict? + --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict? oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2c714abab..e41044aa1 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,6 +51,8 @@ import qualified Database.Esqueleto.Utils as E import Servant.Client.Core.ClientError (ClientError) +import Utils.Mail (pickValidEmail) +import Handler.Utils.Profile (validPostAddressText) -------------------- @@ -472,7 +474,7 @@ upsertAvsUserById api = do -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- forM_ cs $ -- only save used cards for the postal address update detection \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now - upsertUserCompany uid mbCompany userFirmAddr + oldUpsertUserCompany uid mbCompany userFirmAddr return mbUid (Just (Entity _ UserAvs{userAvsUser=uid}) @@ -500,7 +502,7 @@ upsertAvsUserById api = do updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now - upsertUserCompany uid mbCompany userFirmAddr + oldUpsertUserCompany uid mbCompany userFirmAddr forM_ avsPersonPersonCards $ \aCard -> do let fcn = getFullCardNo aCard -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused @@ -640,21 +642,66 @@ queryAvsCardNo crd = do } +_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +_avsFirmPostAddress = to mkPost + where + mkPost AvsFirmInfo{..} = + let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry + commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress + someAddr = fromMaybe "" $ asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] + in if null someAddr + then Nothing + else Just $ plaintextToStoredMarkup $ avsFirmFirm <> Text.cons '\n' someAddr + +_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPrimaryEmail = to mkEmail + where + mkEmail afi = + let candidates = catMaybes + [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail + , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMail + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + +-- | Not sure this is useful, since postal is ignored if there is no post address anyway +_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool +_avsFirmPrefersPostal = to mkPostPref + where + mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) + + + -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting -- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, -- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdate usr newapi oldapi (CheckAvsUpdate up la) +mkUpdate ent newapi oldapi (CheckAvsUpdate up la) | let newval = newapi ^. la , let oldval = oldapi ^. la - , let usrval = getField up usr + , let entval = getField up ent , oldval /= newval - , oldval == usrval + , oldval == entval = Just (up =. newval) mkUpdate _ _ _ _ = Nothing +mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) +mkUpdateDirect dbv inp (CheckAvsUpdate up l) + | let newval = inp ^. l + , let entval = dbv ^. fieldLensVal up + , newval /= entval + = Just (up =. newval) +mkUpdateDirect _ _ _ = Nothing + +-- | Unconditionally update a record through CheckAvsU +updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record +updateRecord dbv inp (CheckAvsUpdate up l) = + let newval = inp ^. l + lensRec = fieldLensVal up + in dbv & lensRec .~ newval + -- | Update given AvsPersonId by querying AVS for each; update only, no insertion! updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId)) @@ -693,20 +740,62 @@ updateAvsUserByIds apids = do [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) ] usr_ups = mcons eml_up $ frm_ups <> per_ups - -- TODO: update Company - -- cmp_up = let - -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) - -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) - -- in - -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) - -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) - avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo - ] - lift $ update usrId usr_ups + ] + _newCompanyId <- lift $ upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + -- TODO: if the company id has changed, update supervision too + lift $ update usrId usr_ups lift $ update uaId avs_ups return $ Set.singleton (apid, usrId) + +-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked +getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company)) +getAvsCompany afi = + let compName :: CompanyName + compName = afi ^. _avsFirmFirm . re _CI + compShorthand :: CompanyShorthand + compShorthand = afi ^. _avsFirmAbbreviation . re _CI + compAvsId = afi ^. _avsFirmFirmNo + in firstJustM + [ getBy $ UniqueCompanyAvsId compAvsId + , getEntity $ CompanyKey compShorthand + , getBy $ UniqueCompanyName compName + ] + +upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB CompanyId +upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do + mbFirmEnt <- getAvsCompany newAvsFirmInfo + case (mbFirmEnt, mbOldAvsFirmInfo) of + (Nothing, _) -> do -- insert new company + let upd = flip updateRecord newAvsFirmInfo + dmy = Company + { companyName = newAvsFirmInfo ^. _avsFirmFirm . re _CI + , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . re _CI + , companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo + , companyPrefersPostal = True + , companyPostAddress = Nothing + , companyEmail = Nothing + } + insert $ foldl' upd dmy firmInfo2company + + (Just Entity{entityKey=firmid }, Nothing) -> do -- neither insert nor update; update impossible without old comparison values, since company could have been edited + $logWarnS "AVS" $ "upsertAvsCompany: neither insert nor update. Received existing company " <> (newAvsFirmInfo ^. _avsFirmFirm) <> " without old comparison value for update." + return firmid + + (Just Entity{entityKey=firmid, entityVal=firm}, Just oldAvsFirmInfo) -> do -- possibly update existing company + let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company + update firmid cmp_ups + return firmid + where + firmInfo2company = + [ CheckAvsUpdate CompanyName $ _avsFirmFirm . re _CI + , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . re _CI + , CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade + -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available + , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress + , CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just + ] diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 034ce56e1..c5451ac11 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -15,9 +15,9 @@ import qualified Data.Text as Text import Database.Persist.Postgresql -- | Ensure that the given user is linked to the given company -upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking -upsertUserCompany uid (Just cName) cAddr | notNull cName = do - cid <- upsertCompany cName cAddr +oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking +oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do + cid <- oldUpsertCompany cName cAddr void $ upsertBy (UniqueUserCompany uid cid) (UserCompany uid cid False False) [] @@ -25,20 +25,20 @@ upsertUserCompany uid (Just cName) cAddr | notNull cName = do upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs ] [] [] [] -upsertUserCompany uid _ _ = +oldUpsertUserCompany uid _ _ = deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? -- | Does not update company address for now -- TODO: update company address, maybe?! -upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId -upsertCompany cName cAddr = +oldUpsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId +oldUpsertCompany cName cAddr = let cName' = CI.mk cName in getBy (UniqueCompanyName cName') >>= \case Just ent -> return $ entityKey ent Nothing -> getBy (UniqueCompanySynonym cName') >>= \case Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent Nothing -> do - let cShort = companyShorthandFromName cName + let cShort = oldCompanyShorthandFromName cName cShort' <- findShort cName' $ CI.mk cShort let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented either entityKey id <$> insertBy compy @@ -52,8 +52,8 @@ upsertCompany cName cAddr = _other -> aux (n+1) -- | Just a cheap heuristic, needs manual intervention anyway -companyShorthandFromName :: Text -> Text -companyShorthandFromName cName = +oldCompanyShorthandFromName :: Text -> Text +oldCompanyShorthandFromName cName = let cpats = splitCamel cName strip = Text.filter Char.isAlphaNum . Text.take 3 spats = strip <$> cpats diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index ee321a491..6072a5b2f 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -7,7 +7,7 @@ module Handler.Utils.Profile ( module Utils.Mail , validDisplayName, checkDisplayName, fixDisplayName - , validPostAddress + , validPostAddress, validPostAddressText , validFraportPersonalNumber ) where @@ -66,14 +66,20 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s -- | Primitive postal address requires at least one alphabetic character, one digit and a line break validPostAddress :: Maybe StoredMarkup -> Bool -validPostAddress (Just StoredMarkup {markupInput = addr}) - | Just _ <- LT.find isLetter addr - , Just _ <- LT.find isNumber addr - -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK - , 1 < length (LT.lines addr) - = True +validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr validPostAddress _ = False +validPostAddressText :: Text -> Bool +validPostAddressText = validPostAddressLazyText . LT.fromStrict + +validPostAddressLazyText :: LT.Text -> Bool +validPostAddressLazyText addr + | Just _ <- LT.find isLetter addr + , Just _ <- LT.find isNumber addr + -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK + = 1 < length (LT.lines addr) +validPostAddressLazyText _ = False + validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber Nothing = False validFraportPersonalNumber (Just t) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index f857dd12f..4f1057bc3 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -27,7 +27,6 @@ import qualified Data.Set as Set import Data.Aeson import Data.Aeson.Types -import Utils.Mail {- -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. @@ -602,7 +601,7 @@ derivePersistFieldJSON ''AvsFirmCommunication data AvsFirmInfo = AvsFirmInfo { avsFirmFirm :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! - , avsFirmFirmNo :: Int + , avsFirmFirmNo :: Int -- bei Verwendung ohne AVS: negative Zahl einsetzen , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! , avsFirmZIPCode :: Maybe Text , avsFirmCity :: Maybe Text @@ -624,16 +623,11 @@ _avsFirmAddress = to mkAddr commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] -_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) -_avsFirmPrimaryEmail = to mkEmail - where - mkEmail afi = - let candidates = catMaybes - [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail - , afi ^. _avsFirmEMailSuperior - , afi ^. _avsFirmEMail - ] - in pickValidEmail candidates -- should we return an invalid email rather than none? +-- Necessarily Moved to Handler.Utils.Avs due to dependencies: +-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool +-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) + instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo diff --git a/src/Utils.hs b/src/Utils.hs index 0e0c3db04..312d19920 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1017,18 +1017,22 @@ forMaybeM :: ( Monad m ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b) forMaybeM = flip mapMaybeM -{- --- Takes computations returnings @Maybes@; tries each one in order. +-- | Only execute second action if the first does not produce a result +altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) +altM ma mb = ma >>= \case + Nothing -> mb + res -> return res + +-- Takes computations returnings @Maybe@; tries each one in order. -- The first one to return a @Just@ wins. Returns @Nothing@ if all computations -- return @Nothing@. -- Copied from GHC.Data.Maybe, which could not be imported somehow. -firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) -firstJustsM = foldlM go Nothing +firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustM = foldlM go Nothing where go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) go Nothing action = action go result@(Just _) _action = return result --} -- | Run the maybe computation repeatedly until the first Just is returned -- or the number of maximum retries is exhausted. diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index d4d0a0f69..d6dc8493e 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -34,8 +34,18 @@ getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record - getFieldEnt = view . fieldLens getField :: PersistEntity record => EntityField record typ -> record -> typ -getField = (. Entity (error "getField required key")) . getFieldEnt +getField = view . fieldLensVal +fieldLensVal :: PersistEntity record => EntityField record field -> Lens' record field +fieldLensVal f = entityLens . fieldLens f + where + entityLens :: Lens' record (Entity record) + entityLens = lens getVal setVal + getVal :: record -> Entity record + getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally + setVal :: record -> Entity record -> record + setVal _ = entityVal + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)