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}
+
+ AVS Konfiguration
+
+ -
+ Host: #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
+
-
+ Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
+
-
+ 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"