fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(avs): fix tests (do not exit with failure on empty avs config)

Browse Source
This commit is contained in:
Sarah Vaupel 2022-06-29 01:25:24 +02:00
parent e03282fedd
commit 89aff47152
3 changed files with 56 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/Application.hs
View File

@ -345,30 +345,30 @@ makeFoundation appSettings''@AppSettings{..} = do
handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
return conn
appAvsQuery <- do
manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
case appAvsConf of
Nothing -> do
$logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
liftIO exitFailure
Just avsConf -> do
-- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup!
let avsServer = BaseUrl
{ baseUrlScheme = Https
, baseUrlHost = avsHost avsConf
, baseUrlPort = avsPort avsConf
, baseUrlPath = ""
}
avsAuth = BasicAuthData
{ basicAuthUsername = avsUser avsConf
, basicAuthPassword = avsPass avsConf
appAvsQuery <- case appAvsConf of
Nothing -> do
$logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings."
return Nothing
-- liftIO exitFailure
Just avsConf -> do
-- TODO: consider using Servant.Client.Core.BaseUrl.Instances.parseBaseUrl' within Settings already at Startup!
manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing
let avsServer = BaseUrl
{ baseUrlScheme = Https
, baseUrlHost = avsHost avsConf
, baseUrlPort = avsPort avsConf
, baseUrlPath = ""
}
(avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
runQuery query = runClientM query $ mkClientEnv manager avsServer
return AvsQuery
{ avsQueryPerson = liftIO . runQuery . avsPersonSearch
, avsQueryStatus = liftIO . runQuery . avsPersonStatus
}
avsAuth = BasicAuthData
{ basicAuthUsername = avsUser avsConf
, basicAuthPassword = avsPass avsConf
}
(avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
runQuery query = runClientM query $ mkClientEnv manager avsServer
return $ Just AvsQuery
{ avsQueryPerson = liftIO . runQuery . avsPersonSearch
, avsQueryStatus = liftIO . runQuery . avsPersonStatus
}
$logDebugS "Runtime configuration" $ tshow appSettings'

2
src/Foundation/Type.hs
View File

@ -99,7 +99,7 @@ data UniWorX = UniWorX
, appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
, appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache
, appStartTime :: UTCTime -- for Status Page
, appAvsQuery :: AvsQuery
, appAvsQuery :: Maybe AvsQuery
} deriving (Typeable)
makeLenses_ ''UniWorX

62
src/Handler/Admin/Avs.hs
View File

@ -53,36 +53,38 @@ validateAvsStatusQuery = do
getAdminAvsR, postAdminAvsR :: Handler Html
getAdminAvsR = postAdminAvsR
postAdminAvsR = do
AvsQuery{..} <- getsYesod $ view _appAvsQuery
postAdminAvsR = do
mAvsQuery <- getsYesod $ view _appAvsQuery
case mAvsQuery of
Nothing -> return mempty
Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
let procFormPerson fr = do
res <- avsQueryPerson fr
case res of
Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn
mbPerson <- formResultMaybe presult procFormPerson
let procFormPerson fr = do
res <- avsQueryPerson fr
case res of
Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn
mbPerson <- formResultMaybe presult procFormPerson
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
res <- avsQueryStatus fr
case res of
Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn
mbStatus <- formResultMaybe sresult procFormStatus
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
res <- avsQueryStatus fr
case res of
Left err -> return . Just $ tshow err
Right jsn -> return . Just $ tshow jsn
mbStatus <- formResultMaybe sresult procFormStatus
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let personForm = wrapForm pwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
statusForm = wrapForm swidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = senctype
}
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let personForm = wrapForm pwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
statusForm = wrapForm swidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = senctype
}
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")