diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9bff17398..26e0fac42 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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|

Success:

Licences sychronized.|] - (Right False) -> - return $ Just [whamlet|

Error:

Licences could not be synchronized, see error log.|] - (Left e) -> do - let msg = tshow (e :: SomeException) - return $ Just [whamlet|

Error:

#{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| +

Licence check differences: +

Grant R: +

+ #{r_grant} +

Set to F: +

+ #{f_set} +

Revoke licence: +

+ #{revoke} + |] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Licence check error:

#{msg}|] + BtnSynchLicences -> do + res <- try checkLicences + case res of + (Right True) -> + return $ Just [whamlet|

Success:

Licences sychronized.|] + (Right False) -> + return $ Just [whamlet|

Error:

Licences could not be synchronized, see error log.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Licence synchronisation error:

#{msg}|] mbQryLic <- formResultMaybe qryLicRes procFormQryLic actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 4a2df7730..6389dc807 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -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) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9c4dec62d..176fd8175 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 3606bb2c0..7f1807b90 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index 227cc2e4d..a2b2a1533 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -22,3 +22,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later UTF8: #{presentUtf8 lv} — Latin: #{presentLatin1 lv} +
+

+ LDAP Upsert user in DB: + ^{upsertForm} + $maybe answer <- mbLdapUpsert +

+ Antwort: # +

+ #{tshow answer}