From ef36e22f7617bdf7910f606002c871a46f763cc1 Mon Sep 17 00:00:00 2001
From: Steffen Jost <s.jost@fraport.de>
Date: Tue, 13 Feb 2024 16:25:58 +0100
Subject: [PATCH] chore(avs): make avs timeouts setting configurable

---
 config/settings.yml             | 10 ++++++----
 src/Handler/Admin/Avs.hs        | 10 +++++++++-
 src/Handler/Qualification.hs    |  7 ++++---
 src/Handler/Utils/Avs.hs        |  8 +++++---
 src/Handler/Utils/Concurrent.hs |  6 ++++++
 src/Settings.hs                 | 14 ++++++++++----
 6 files changed, 40 insertions(+), 15 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 68bed4958..b3b61a502 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -157,10 +157,12 @@ lms-direct:
   deletion-days:        "_env:LMSDELETIONDAYS:7"
 
 avs:
-  host:    "_env:AVSHOST:skytest.fra.fraport.de"
-  port:    "_env:AVSPORT:443"
-  user:    "_env:AVSUSER:fradrive"
-  pass:    "_env:AVSPASS:"
+  host:         "_env:AVSHOST:skytest.fra.fraport.de"
+  port:         "_env:AVSPORT:443"
+  user:         "_env:AVSUSER:fradrive"
+  pass:         "_env:AVSPASS:"
+  timeout:      "_env:AVSTIMEOUT:42"
+  cache-expiry: "_env:AVSCACHEEXPIRY:420"
 
 lpr:
   host:    "_env:LPRHOST:fravm017173.fra.fraport.de"
diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 871ee1634..836e7e6dc 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -140,7 +140,15 @@ postAdminAvsR = do
   mbAvsConf <- getsYesod $ view _appAvsConf
   let avsWgt = [whamlet|
           $maybe avsConf <- mbAvsConf
-            AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
+            <h2>
+              AVS Konfiguration
+            <ul>
+              <li>
+                Host:  #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
+              <li>
+                Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
+              <li>
+                Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
           $nothing
             AVS nicht konfiguriert!
         |]
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 67a7e4bd6..0005b82b6 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -420,9 +420,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       --     )      
       , single ("avs-card"  , FilterColumnHandler $ \case
           [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool))
-          cs -> 
+          cs -> do
             let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
-            in  timeoutHandler (0 * 30 * 1000000) (queryAvsCardNos crds) >>= \case 
+            toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
+            maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case 
               Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
                                     >> return (const E.false)
               (Just (null -> True)) -> return (const E.false)
@@ -462,7 +463,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
       , prismAForm (singletonFilter "user-company")                             mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" )                         mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-      , prismAForm (singletonFilter "avs-card" )                                mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded])
+      , prismAForm (singletonFilter "avs-card" )                                mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]))
       , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
       , prismAForm (singletonFilter "validity"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
       , if isNothing mbRenewal then mempty
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 63dfbc9d0..a70285bba 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -587,9 +587,11 @@ queryAvsCardNo crd = do
                                        }
 
 avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
-avsPersonQueryCached apq = memcachedBy (Just . Right $ 5 * diffMinute) apq $ do     -- TODO using settings for time
-  AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  throwLeftM $ avsQueryPerson apq
+avsPersonQueryCached apq = do 
+  cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+  memcachedBy cexpire apq $ do
+    AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+    throwLeftM $ avsQueryPerson apq
 
 
 -- A datatype for a specific heterogeneous list
diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs
index 1faaff498..3328cced4 100644
--- a/src/Handler/Utils/Concurrent.hs
+++ b/src/Handler/Utils/Concurrent.hs
@@ -13,6 +13,12 @@ import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
 
 
 
+maybeTimeoutHandler :: Maybe Int -> HandlerFor site a -> HandlerFor site (Maybe a)
+maybeTimeoutHandler Nothing     = fmap Just
+maybeTimeoutHandler (Just secs) = timeoutHandler $ bool maxBound micro (micro > 0)
+  where 
+    micro = 1000000 * secs
+
 -- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
 timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
 timeoutHandler maxWait act = do
diff --git a/src/Settings.hs b/src/Settings.hs
index e3fcc6105..45738751e 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -330,6 +330,8 @@ data AvsConf = AvsConf
   , avsPort :: Int
   , avsUser :: ByteString
   , avsPass :: ByteString
+  , avsTimeout      :: Int      -- Seconds; wait time for some online user queries
+  , avsCacheExpiry  :: DiffTime -- Seconds, only for non-licence related queries
   } deriving (Show)
 
 data LprConf = LprConf
@@ -529,12 +531,16 @@ makeLenses_ ''LmsConf
 
 instance FromJSON AvsConf where
   parseJSON = withObject "AvsConf" $ \o -> do
-    avsHost <- o .: "host"
-    avsPort <- o .: "port"
-    avsUser <- o .: "user"
-    avsPass <- o .:? "pass" .!= ""
+    avsHost         <- o .: "host"
+    avsPort         <- o .: "port"
+    avsUser         <- o .: "user"
+    avsPass         <- o .:? "pass" .!= ""
+    avsTimeout      <- o .: "timeout"
+    avsCacheExpiry  <- o .: "cache-expiry"
     return AvsConf{..}
 
+makeLenses_ ''AvsConf    
+
 instance FromJSON LprConf where
   parseJSON = withObject "LprConf" $ \o -> do
     lprHost  <- o .: "host"