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

2
src/Foundation/Type.hs
View File

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

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

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