From 494f86a5f7229f790f8172327d0d7a2ab1145b69 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Nov 2022 18:13:54 +0100 Subject: [PATCH] chore(avs): creating new users by cardno or internpersno completed --- src/Handler/Utils/Avs.hs | 54 ++++++++++++++++++++++++---------------- src/Model/Types/Avs.hs | 43 +++++++++++++++++++++++++++++--- src/Utils/Print.hs | 6 ++--- 3 files changed, 76 insertions(+), 27 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3f89cc8c8..dbbd5bbaf 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -116,14 +116,21 @@ checkLicences = do error "CONTINUE HERE" -- TODO STUB - upsertAvsUser :: Text -> Handler (Maybe UserId) -upsertAvsUser _someid = error "TODO" -- TODO STUB -{- - | isAvsId someid = error "TODO" - | isEmail someid = error "TODO" - | isNumber someid = error "TODO" --} +-- upsertAvsUser (readAvsFullCardNo -> Just afcn) = upsertAvsUserByCard afcn +-- upsertAvsUser someid +-- | Just avsid <- discernAvsIds someid +-- = upsertAvsUserByCard $ over _Right (const someid) avsid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot discern, but the latter is much more likely and useful! +upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid +upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary now + {- maybe this code helps? + upsRes :: Either CampusUserConversionException (Entity User) + <- try $ upsertCampusUserByOther persNo + case upsRes of + Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid + _other -> return mbuid -- ==Nothing -- user could not be created somehow + -} + -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen). @@ -167,22 +174,27 @@ upsertAvsUserById api = do , aufFDepartment = Nothing , aufPostAddress = plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress , aufPrefersPostal = isJust firmAddress - , aufPinPassword = getFullCardNo <$> bestCard + , aufPinPassword = tshowAvsFullCardNo . getFullCardNo <$> bestCard , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , aufIdent = fakeIdent -- use AvsPersonId instead , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known } - mbUid <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe - case (mbCompany, mbUid) of - (Just cpy, Just uid) -> runDB $ do - cid <- upsertCompany cpy - insert_ $ UserCompany cid uid False - _ -> return () + mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe + case mbUid of + Just uid -> runDB $ do + now <- liftIO getCurrentTime + insert_ $ UserAvs avsPersonPersonID uid + -- forM_ avsPersonPersonCards $ -- save all cards for later + forM_ bestCard $ -- only save the card used to the postal address + \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now + case mbCompany of + Just cpy -> do + cid <- upsertCompany cpy + insert_ $ UserCompany cid uid False + _ -> return () + _ -> return () + return mbUid - - -- _newAvs = UserAvs avsPersonPersonID uid - -- _newAvsCards = UserAvsCard - error "TODO" -- CONTINUE HERE (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates error "TODO" -- CONTINUE HERE @@ -192,11 +204,11 @@ upsertAvsUserById api = do --upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => -- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) upsertAvsUserByCard :: - Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! + Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard persNo = do let qry = case persNo of - Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn } - Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } + Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } + Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry case Set.elems adps of diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 16e0e78f1..b3a441dc0 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -18,6 +18,7 @@ import qualified Data.Csv as Csv import Utils.Lens.TH import Text.Read (Read(..)) +import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Set as Set @@ -80,7 +81,7 @@ instance FromJSON SloppyBool where -- AVS Datatypes -- ------------------- -type AvsInternalPersonalNo = Text -- type synonym for clarity/documentation within types +type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types -- CompleteCardNo = xxxxxxxx.y -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo @@ -98,6 +99,31 @@ instance ToJSON AvsCardNo where normalizeAvsCardNo :: Text -> Text normalizeAvsCardNo = Text.justifyRight 8 '0' +data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo } + deriving (Eq, Ord, Generic, Typeable) + +tshowAvsFullCardNo :: AvsFullCardNo -> Text +tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion + +instance Show AvsFullCardNo where + show = Text.unpack . tshowAvsFullCardNo + +readAvsFullCardNo :: Text -> Maybe AvsFullCardNo +readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v))) + | not $ Text.null c, Just (Char.isDigit -> True, "") <- Text.uncons v + = Just $ AvsFullCardNo (AvsCardNo c) v +readAvsFullCardNo _ = Nothing + +discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point +discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) + | Text.null pv + = Just $ Right c + | not $ Text.null c + , Just ('.', v) <- Text.uncons pv + , Just (Char.isDigit -> True, "") <- Text.uncons v + = Just $ Left $ AvsFullCardNo (AvsCardNo c) v +discernAvsCardPersonalNo _ = Nothing + -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic, Typeable) @@ -127,6 +153,17 @@ deriveJSON defaultOptions } ''AvsObjPersonId +discernAvsIds :: Text -> Maybe (Either AvsFullCardNo AvsPersonId) +discernAvsIds someid = aux someid + where + aux (Text.uncons -> Just (h,t)) + | Char.isDigit h = aux t + | h == '.', Just (h2, t2) <- Text.uncons t, Text.null t2, Char.isDigit h2 + , let afcn = AvsFullCardNo (AvsCardNo $ Text.dropEnd 2 someid) (Text.singleton h2) + = Just $ Left afcn + | otherwise = Nothing + aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point + data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) @@ -252,8 +289,8 @@ instance ToJSON AvsDataPersonCard where ] derivePersistFieldJSON ''AvsDataPersonCard -getFullCardNo :: AvsDataPersonCard -> Text -getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = avsCardNo avsDataCardNo <> Text.cons '.' avsDataVersionNo +getFullCardNo :: AvsDataPersonCard -> AvsFullCardNo +getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo avsDataCardNo avsDataVersionNo data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index ff5a65bcb..e6f4a3b1b 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -487,9 +487,9 @@ sendEmailOrLetter recipient letter = do -- | Converts Triple consisting of @ExitCode@, Success- and Failure-Value to Either Failue- or Success-Value. -- Returns @Right@ if the @ExitCode@ is @ExitsSuccess, entirely ignoring the Failure-Value, which might contain warning messages. -- To be used with 'System.Process.Typed.readProcess' -exit2either :: (ExitCode, a, b) -> Either b a -exit2either (ExitSuccess , ok, _) = Right ok -- warnings are ignored here! -exit2either (ExitFailure _ , _, err) = Left err +exit2either :: Monoid a => (ExitCode, a, a) -> Either a a +exit2either (ExitSuccess , stdOut, errOut) = Right $ stdOut <> errOut +exit2either (ExitFailure _ , stdOut, errOut) = Left $ stdOut <> errOut readProcess' :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Text, Text)