refactor(avs): rework createAvsUserById (WIP)
This commit is contained in:
parent
54c08cc64b
commit
3b7762f451
@ -39,3 +39,12 @@ AvsCardColorRed: Rot
|
||||
AvsCardColorYellow: Gelb
|
||||
LastAvsSynchronisation: Letzte AVS-Synchronisation
|
||||
LastAvsSynchError: Letzte AVS-Fehlermeldung
|
||||
|
||||
AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
|
||||
AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
|
||||
AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
|
||||
AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
|
||||
AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
|
||||
AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
|
||||
AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
|
||||
AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
|
||||
@ -38,4 +38,13 @@ AvsCardColorBlue: Blue
|
||||
AvsCardColorRed: Red
|
||||
AvsCardColorYellow: Yellow
|
||||
LastAvsSynchronisation: Last AVS synchronisation
|
||||
LastAvsSynchError: Last AVS Error
|
||||
LastAvsSynchError: Last AVS Error
|
||||
|
||||
AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
|
||||
AvsUserUnassociated user: AVS id unknown for user #{user}
|
||||
AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known)
|
||||
AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
|
||||
AvsPersonSearchEmpty: AVS search returned empty result
|
||||
AvsPersonSearchAmbiguous: AVS search returned more than one result
|
||||
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
|
||||
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
|
||||
@ -15,8 +15,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
displayName UserDisplayName
|
||||
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
|
||||
email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown
|
||||
ident UserIdent -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
created UTCTime default=now()
|
||||
@ -44,7 +44,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
mobile Text Maybe
|
||||
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
|
||||
pinPassword Text Maybe -- used to encrypt pins within emails, defaults to cardno.version
|
||||
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
|
||||
prefersPostal Bool default=false -- user prefers letters by post instead of email
|
||||
|
||||
@ -34,19 +34,26 @@ import Import
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import Utils.Avs
|
||||
import Utils.Users
|
||||
-- import Utils.Users
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.Catch as Catch
|
||||
|
||||
-- import Auth.LDAP (ldapUserPrincipalName)
|
||||
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
|
||||
|
||||
|
||||
import Utils.Mail (pickValidEmail)
|
||||
import Utils.Users
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Profile (validPostAddressText)
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Qualification
|
||||
import Handler.Utils.Memcached
|
||||
import Handler.Utils.Users
|
||||
|
||||
import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
@ -56,8 +63,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Servant.Client.Core.ClientError (ClientError)
|
||||
|
||||
import Utils.Mail (pickValidEmail)
|
||||
import Handler.Utils.Profile (validPostAddressText)
|
||||
|
||||
|
||||
--------------------
|
||||
@ -66,26 +71,37 @@ import Handler.Utils.Profile (validPostAddressText)
|
||||
|
||||
data AvsException
|
||||
= AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond
|
||||
| AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet
|
||||
| AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB
|
||||
| AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found in our DB
|
||||
| AvsUserUnassociated Text -- Manipulating AVS Data for a user that is not linked to AVS yet
|
||||
| AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS
|
||||
| AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found for a query in AVS or DB
|
||||
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
|
||||
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
|
||||
| AvsSetLicencesFailed Text -- AvsSetLicence total failure
|
||||
| AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
instance Exception AvsException
|
||||
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n
|
||||
|
||||
{-
|
||||
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
|
||||
|
||||
handleAvsExceptions = (`catches` handlers)
|
||||
where
|
||||
handlers =
|
||||
[ Handler (\(e::AvsException -> handleAvsException e))
|
||||
, Handler (\(e::ClientError -> handleClientError e))
|
||||
]
|
||||
-}
|
||||
|
||||
-- | Catch AVS exceptions and display them as messages
|
||||
-- catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
|
||||
catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
|
||||
catchAVS2message act = act `catches` handlers
|
||||
where
|
||||
handlers =
|
||||
[ Catch.Handler (\(exc::AvsException) -> addMessageI Warning exc >> return Nothing)
|
||||
, Catch.Handler (\(exc::ClientError ) -> do
|
||||
let msg = "AVS fatal communicaton failure: " <> tshow exc
|
||||
$logErrorS "AVS" msg
|
||||
addMessage Warning $ toHtml msg
|
||||
return Nothing
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
------------------
|
||||
-- AVS Handlers --
|
||||
------------------
|
||||
@ -412,6 +428,17 @@ queryAvsCardNo crd = do
|
||||
, avsPersonQueryVersionNo = Just avsFullCardVersion
|
||||
}
|
||||
|
||||
-- | Queries AVS Status to retrieve primary card
|
||||
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
|
||||
queryAvsPrimaryCard api = runMaybeT $ do
|
||||
AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
|
||||
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
|
||||
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
|
||||
|
||||
-- | Queries AVS to retrieve pin generated from primary card no
|
||||
queryAvsPin :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe Text)
|
||||
queryAvsPin = fmap (fmap personCard2pin) . queryAvsPrimaryCard
|
||||
|
||||
|
||||
_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
|
||||
_avsFirmPostAddress = to mkPost
|
||||
@ -447,7 +474,7 @@ _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
|
||||
@ -623,13 +650,44 @@ createAvsUserById api = do
|
||||
case Set.toList res of
|
||||
[] -> return Nothing
|
||||
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
||||
[AvsDataContact{..}] -> runDB $ do
|
||||
_now <- liftIO getCurrentTime
|
||||
let uid = error "CONTINUE HERE"
|
||||
Entity{entityKey=cid, entityVal=_} <- upsertAvsCompany avsContactFirmInfo Nothing
|
||||
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
|
||||
void $ insertUnique userComp
|
||||
return $ Just uid
|
||||
[AvsDataContact{avsContactPersonInfo=cpi,..}]
|
||||
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
|
||||
| otherwise -> do
|
||||
pinPass <- queryAvsPin api
|
||||
runDB $ do
|
||||
Entity{entityKey=cid, entityVal=cmp} <- upsertAvsCompany avsContactFirmInfo Nothing
|
||||
-- _now <- liftIO getCurrentTime
|
||||
let
|
||||
internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
||||
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
||||
_newUser = AddUserData
|
||||
{ audTitle = Nothing
|
||||
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
|
||||
, audSurname = cpi ^. _avsInfoLastName & Text.strip
|
||||
, audDisplayName = cpi ^. _avsInfoDisplayName
|
||||
, audDisplayEmail = persMail & fromMaybe mempty
|
||||
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
|
||||
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
|
||||
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
|
||||
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
|
||||
, audSex = Nothing
|
||||
, audBirthday = cpi ^. _avsInfoDateOfBirth
|
||||
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
|
||||
, audTelephone = Nothing
|
||||
, audFPersonalNumber = internalPersNo
|
||||
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
|
||||
, audPostAddress = Nothing -- use company address indirectly
|
||||
, audPrefersPostal = cmp ^. _companyPrefersPostal
|
||||
, audPinPassword = pinPass
|
||||
}
|
||||
|
||||
let uid = error "CONTINUE HERE"
|
||||
|
||||
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
|
||||
void $ insertUnique userComp
|
||||
-- TODO: insert supervisors
|
||||
-- TODO: add superior from firmInfo
|
||||
return $ Just uid
|
||||
|
||||
|
||||
|
||||
@ -662,7 +720,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
, companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo
|
||||
, companyPrefersPostal = True
|
||||
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
|
||||
, companyEmail = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just
|
||||
, companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
|
||||
}
|
||||
newCmp <- insertEntity $ foldl' upd dmy firmInfo2company
|
||||
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
|
||||
@ -694,18 +752,18 @@ guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
|
||||
let avsid = AvsPersonId nr in
|
||||
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
|
||||
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
|
||||
Nothing -> maybeCatchAll $ upsertAvsUserById avsid
|
||||
Nothing -> catchAVS2message $ upsertAvsUserById avsid
|
||||
| prefix=="AVSNO:" =
|
||||
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
||||
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
|
||||
maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
|
||||
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
|
||||
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
|
||||
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
|
||||
other -> return other
|
||||
guessAvsUser someid = do
|
||||
try (runDB $ ldapLookupAndUpsert someid) >>= \case
|
||||
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
|
||||
maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
|
||||
catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
|
||||
Nothing -> Just uid
|
||||
other -> other
|
||||
Right Entity{entityKey=uid} -> return $ Just uid
|
||||
@ -746,7 +804,8 @@ upsertAvsUserById0 api = do
|
||||
[] -> createAvsUserById api
|
||||
[(api',uid)]
|
||||
| api == api' -> return $ Just uid
|
||||
| otherwise -> error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with API " <> show api' <> " for queried API " <> show api <> "."
|
||||
| otherwise -> throwM $ AvsIdMismatch api api'
|
||||
-- error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
|
||||
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
||||
|
||||
|
||||
@ -755,9 +814,12 @@ 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
|
||||
setLicence uid lic =
|
||||
getBy (UniqueUserAvsUser uid) >>= \case
|
||||
Just (Entity{entityVal=UserAvs{userAvsPersonId=api}}) -> setLicenceAvs api lic
|
||||
Nothing -> do
|
||||
uname <- userDisplayName <<$>> get uid
|
||||
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
|
||||
|
||||
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
AvsPersonId -> AvsLicence -> m Bool
|
||||
|
||||
@ -417,6 +417,9 @@ getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo
|
||||
personCard2pin :: AvsDataPersonCard -> Text
|
||||
personCard2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo . getFullCardNo
|
||||
|
||||
personCards2pin :: Set AvsDataPersonCard -> Maybe Text
|
||||
personCards2pin = fmap personCard2pin . Set.lookupMax
|
||||
|
||||
data AvsStatusPerson = AvsStatusPerson
|
||||
{ avsStatusPersonID :: AvsPersonId
|
||||
, avsStatusPersonCardStatus :: Set AvsDataPersonCard -- only delivers non-Maybe fields, all Maybe-fields are Nothing
|
||||
|
||||
@ -314,6 +314,9 @@ stripFold = Text.toCaseFold . Text.strip
|
||||
ciOriginal :: CI Text -> Text
|
||||
ciOriginal = CI.original
|
||||
|
||||
ciShow :: Show a => a -> CI Text
|
||||
ciShow = CI.mk . tshow
|
||||
|
||||
citext2lower :: CI Text -> Text
|
||||
citext2lower = Text.toLower . CI.original
|
||||
|
||||
|
||||
@ -49,10 +49,11 @@ data AddUserData = AddUserData
|
||||
, audPinPassword :: Maybe Text
|
||||
, audEmail :: UserEmail
|
||||
, audIdent :: UserIdent
|
||||
, audAuth :: AuthenticationKind
|
||||
, audAuth :: AuthenticationKind
|
||||
}
|
||||
|
||||
-- | Adds a new user to database, no background jobs are scheduled, no notifications send
|
||||
-- Note: Foundation.Yesod.Auth contains similar code with potentially differing defaults!
|
||||
addNewUser :: AddUserData -> Handler (Maybe UserId)
|
||||
addNewUser AddUserData{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
Loading…
Reference in New Issue
Block a user