diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index fd3b39fa8..0e4de3deb 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -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} \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index ccaeb9012..e572b8888 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -38,4 +38,13 @@ AvsCardColorBlue: Blue AvsCardColorRed: Red AvsCardColorYellow: Yellow LastAvsSynchronisation: Last AVS synchronisation -LastAvsSynchError: Last AVS Error \ No newline at end of file +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 \ No newline at end of file diff --git a/models/users.model b/models/users.model index 97734a347..5597a7375 100644 --- a/models/users.model +++ b/models/users.model @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 517940451..2fbb57d46 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index b9b0fb2d5..6168c52cb 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 1ce464ec1..ef6e5b2d8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index c5d08cef6..f6acc88c3 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -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