From 89aff471528ad9002e309d50d706a412b7e67eb6 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 29 Jun 2022 01:25:24 +0200 Subject: [PATCH] fix(avs): fix tests (do not exit with failure on empty avs config) --- src/Application.hs | 46 ++++++++++++++--------------- src/Foundation/Type.hs | 2 +- src/Handler/Admin/Avs.hs | 62 +++++++++++++++++++++------------------- 3 files changed, 56 insertions(+), 54 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 3edcea9f2..c68926a23 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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' diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 3ac04c100..7fbe294a6 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index cf5be59a6..0d9f708a1 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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")