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

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
+  btnLabel    BtnCheckLicences = "Check all licences"       -- could be msg
-  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
+  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
+      let procFormQryLic btn = case btn of 
-            res <- try checkLicences
+            BtnCheckLicences -> do 
-            case res of
+              res <- try $ do                 
-              (Right True) ->
+                allLicences <- throwLeftM avsQueryGetAllLicences
-                return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+                computeDifferingLicences allLicences
-              (Right False) ->
+              case res of 
-                return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+                (Right diffs) -> do 
-              (Left e) -> do
+                  let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-                let msg = tshow (e :: SomeException)
+                      r_grant = showLics AvsLicenceRollfeld
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+                      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

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 []))
+  let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
-      procFormPerson LdapQueryPerson{..} = do
+      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
+          ldapData <- campusUser'' ldapPool FailoverUnlimited lid                      
-                         | Just lqn <- ldapQueryPNum  -> campusUserMatr' ldapPool FailoverUnlimited lqn
+          decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
-                         | otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
-          decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ 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)
 

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
+    [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update 
-      mbuid <- runDB $ getBy $ UniqueUserAvsId appi
+      -- do
-      case mbuid of
+        -- mbuid <- runDB $ getBy $ UniqueUserAvsId api
-        (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
+        -- case mbuid of
-        Nothing -> upsertAvsUserById appi
+          -- (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

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

templates/ldap.hamlet

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