fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): add facilities to debug avs and ldap, chunk set avs licences

Browse Source
This commit is contained in:
Steffen Jost 2022-12-02 12:19:52 +01:00
parent d224443721
commit b30260a50e
5 changed files with 91 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
src/Handler/Admin/Avs.hs
View File

@ -19,7 +19,7 @@ import Handler.Utils.Avs
import Utils.Avs
-- Button needed only here
data ButtonAvsTest = BtnCheckLicences
data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAvsTest
instance Finite ButtonAvsTest
@ -27,8 +27,10 @@ instance Finite ButtonAvsTest
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
instance Button UniWorX ButtonAvsTest where
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
-- END Button
@ -180,16 +182,42 @@ postAdminAvsR = do
((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
let procFormQryLic BtnCheckLicences = do
res <- try checkLicences
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
let procFormQryLic btn = case btn of
BtnCheckLicences -> do
res <- try $ do
allLicences <- throwLeftM avsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
BtnSynchLicences -> do
res <- try checkLicences
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute

55
src/Handler/Admin/Ldap.hs
View File

@ -10,67 +10,47 @@ module Handler.Admin.Ldap
) where
import Import
import qualified Control.Monad.State.Class as State
-- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest)
import Foundation.Yesod.Auth (decodeUserTest,upsertCampusUserByCn,CampusUserConversionException())
import Handler.Utils
import qualified Ldap.Client as Ldap
import Auth.LDAP
data LdapQueryPerson = LdapQueryPerson
{ ldapQueryIdent :: Maybe Text
-- , ldapQueryName :: Maybe Text
, ldapQueryPNum :: Maybe Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ LdapQueryPerson
<$> aopt textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl)
-- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl)
<*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl)
validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
validateLdapQueryPerson = do
LdapQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $
is _Just ldapQueryIdent ||
-- is _Just ldapQueryName ||
is _Just ldapQueryPNum
getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR
postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
procFormPerson LdapQueryPerson{..} = do
let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
procFormPerson lid = do
ldapPool' <- getsYesod $ view _appLdapPool
if isNothing ldapPool'
then addMessage Warning $ text2Html "LDAP Configuration missing."
else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser'' ldapPool FailoverUnlimited lqi
| Just lqn <- ldapQueryPNum -> campusUserMatr' ldapPool FailoverUnlimited lqn
| otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData
ldapData <- campusUser'' ldapPool FailoverUnlimited lid
decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
procFormUpsert lid = pure <$> runDB (try (upsertCampusUserByCn lid))
mbLdapUpsert <- formResultMaybe uresult procFormUpsert
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
siteLayoutMsg MsgMenuLdap $ do
setTitleI MsgMenuLdap
@ -78,7 +58,10 @@ postAdminLdapR = do
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
upsertForm = wrapForm uwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = uenctype
}
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)

31
src/Handler/Utils/Avs.hs
View File

@ -8,9 +8,10 @@
module Handler.Utils.Avs
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, setLicence, setLicenceAvs, setLicencesAvs
, setLicence, setLicenceAvs, setLicencesAvs, computeDifferingLicences
, checkLicences
, lookupAvsUser, lookupAvsUsers
, AvsException(..)
) where
import Import
@ -116,7 +117,8 @@ setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
Set AvsPersonLicence -> m Bool
setLicencesAvs pls = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences batch1
case response of
AvsResponseSetLicencesError{..} -> do
let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
@ -125,10 +127,14 @@ setLicencesAvs pls = do
AvsResponseSetLicences msgs -> do
let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs
batch1_ok = length ok == length batch1
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-- TODO: Admin Error page
return $ length ok == length pls
if Set.null batch2
then return batch1_ok
else (batch1_ok &&) <$> setLicencesAvs batch2 -- yay for recursion (TODO: 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
@ -216,7 +222,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
-- | Always update AVS Data
upsertAvsUser :: Text -> Handler (Maybe UserId)
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
@ -229,7 +235,7 @@ upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eM
-}
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
upsertAvsUserByCard persNo = do
@ -241,11 +247,12 @@ upsertAvsUserByCard persNo = do
case Set.elems adps of
[] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=appi}] -> do
mbuid <- runDB $ getBy $ UniqueUserAvsId appi
case mbuid of
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
Nothing -> upsertAvsUserById appi
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
-- do
-- mbuid <- runDB $ getBy $ UniqueUserAvsId api
-- case mbuid of
-- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
-- Nothing -> upsertAvsUserById api
@ -259,13 +266,15 @@ upsertAvsUserById api = do
case (mbuid, mbapd) of
(Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
| Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
$logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
case candidates of
[uid] -> insertUniqueEntity $ UserAvs api uid
[uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid)
(_:_) -> throwM AvsUserAmbiguous
[] -> do
upsRes :: Either CampusUserConversionException (Entity User)
<- try $ upsertCampusUserByCn persNo
$logInfoS "AVS" $ "No matching user found. attempted LDAP upsert returned: " <> tshow upsRes
case upsRes of
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway
_other -> return mbuid -- ==Nothing -- user could not be created somehow

2
src/Utils/Avs.hs
View File

@ -27,6 +27,8 @@ type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Po
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsApi :: Proxy AVS
avsApi = Proxy

9
templates/ldap.hamlet
View File

@ -22,3 +22,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}
<section>
<p>
LDAP Upsert user in DB:
^{upsertForm}
$maybe answer <- mbLdapUpsert
<h1>
Antwort: #
<p>
#{tshow answer}