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}