From 66dd1a8b70468a51aca0eba82369833acc8dcb3d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 28 Jun 2022 21:50:54 +0200 Subject: [PATCH] feat(avs): disable certificate validation for avs api --- package.yaml | 1 + src/Application.hs | 41 +++++++-- src/Foundation/Type.hs | 5 +- src/Handler/Admin/Avs.hs | 17 ++-- src/Handler/Utils/Servant/Avs.hs | 144 ------------------------------- src/Utils/Avs.hs | 56 ++++++++++++ 6 files changed, 107 insertions(+), 157 deletions(-) delete mode 100644 src/Handler/Utils/Servant/Avs.hs create mode 100644 src/Utils/Avs.hs diff --git a/package.yaml b/package.yaml index 2ba331d33..0556908ee 100644 --- a/package.yaml +++ b/package.yaml @@ -121,6 +121,7 @@ dependencies: - semigroupoids - http-types - http-client + - http-client-tls - jose-jwt - mono-traversable - mono-traversable-keys diff --git a/src/Application.hs b/src/Application.hs index e3cd25755..2364b1237 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -31,6 +31,7 @@ import Network.Wai.Handler.Warp (Settings, defaultSettings, runSettings, runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) +import Network.Connection (settingDisableCertificateValidation) import Data.Streaming.Network (bindPortTCP) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), @@ -119,6 +120,8 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) import qualified System.Clock as Clock +import Utils.Avs + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.News @@ -153,6 +156,11 @@ import Handler.Swagger import ServantApi () -- YesodSubDispatch instances +import Servant.API +import Servant.Client +import Network.HTTP.Client.TLS (mkManagerSettings) + + -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- comments there for more details. @@ -221,10 +229,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache = UniWorX {..} - -- The UniWorX {..} syntax is an example of record wild cards. For more - -- information, see: - -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") @@ -243,6 +248,7 @@ makeFoundation appSettings''@AppSettings{..} = do (error "AuthKey forced in tempFoundation") (error "PersonalisedSheetFilesSeedKey forced in tempFoundation") (error "VolatileClusterSettingsCache forced in tempFoundation") + (error "AvsQuery forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -339,9 +345,34 @@ 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 + } + (avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth + runQuery query = runClientM query $ mkClientEnv manager avsServer + return AvsQuery + { avsQueryPerson = \query -> liftIO . runQuery $ avsPersonSearch query + , avsQueryStatus = \query -> liftIO . runQuery $ avsPersonStatus query + } + $logDebugS "Runtime configuration" $ tshow appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logDebugS "setup" "Done" diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 0c7468be1..3ac04c100 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -10,7 +10,7 @@ module Foundation.Type , AppMemcachedLocal(..) , _memcachedLocalARC , SMTPPool - , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache + , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery , DB, Form, MsgRenderer, MailM, DBFile ) where @@ -39,6 +39,8 @@ import Data.Time.Clock.POSIX (POSIXTime) import GHC.Fingerprint (Fingerprint) import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey) +import Utils.Avs (AvsQuery) + type SMTPPool = Pool SMTPConnection @@ -97,6 +99,7 @@ data UniWorX = UniWorX , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey , appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache , appStartTime :: UTCTime -- for Status Page + , appAvsQuery :: AvsQuery } deriving (Typeable) makeLenses_ ''UniWorX diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 7b8062802..cf5be59a6 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -10,8 +10,8 @@ import qualified Data.Text as Text import qualified Data.Set as Set import Handler.Utils -import Handler.Utils.Servant.Avs +import Utils.Avs makeAvsPersonForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery @@ -54,20 +54,23 @@ validateAvsStatusQuery = do getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do + AvsQuery{..} <- getsYesod $ view _appAvsQuery + ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing + let procFormPerson fr = do - res <- runAvsPersonSearch fr + res <- avsQueryPerson fr case res of - Left err -> return $ Just err - Right jsn -> return $ Just $ tshow jsn + 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 <- runAvsStatusSearch fr + res <- avsQueryStatus fr case res of - Left err -> return $ Just err - Right jsn -> return $ Just $ tshow jsn + Left err -> return . Just $ tshow err + Right jsn -> return . Just $ tshow jsn mbStatus <- formResultMaybe sresult procFormStatus actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute diff --git a/src/Handler/Utils/Servant/Avs.hs b/src/Handler/Utils/Servant/Avs.hs deleted file mode 100644 index 7cea50128..000000000 --- a/src/Handler/Utils/Servant/Avs.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - -module Handler.Utils.Servant.Avs where - -import Import -import Servant -import Servant.Client --- import Servant.API.Flatten -- requires package servant-flatten - -import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) - - - -data AvsPersonQuery = AvsPersonQuery - { avsPersonQueryCardNo :: Maybe Text - , avsPersonQueryFirstName :: Maybe Text - , avsPersonQueryLastName :: Maybe Text - , avsPersonQueryInternalPersonalNo :: Maybe Text - , avsPersonQueryVersionNo :: Maybe Text - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Default AvsPersonQuery where - def = AvsPersonQuery Nothing Nothing Nothing Nothing Nothing - -deriveJSON defaultOptions - { fieldLabelModifier = mconcat . drop 3 . splitCamel - , omitNothingFields = True - , tagSingleConstructors = False - } ''AvsPersonQuery - -{- - data PersonResponse = Person {..TODO..} - data StatusResponse = StatusResponse --} - - -- data StatusQuery = StatusQuery -newtype AvsStatusQuery = AvsStatusQuery (Set Int) -deriveJSON defaultOptions ''AvsStatusQuery - -type AvsPersonResponse = Value -type AvsStatusResponse = Value - -type AVSAuth = BasicAuth "avs_fradrive" String - ---type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse - -- :<|> ("PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse)) - - -type AVSRoute a = AVSAuth :> "FraVSMService" :> "v1" :> a -type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse -type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse - -avsApi :: Proxy AVS -avsApi = Proxy - -{- --- Option 1: -type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus) -avsPersonSearch :: AvsPersonQuery -> ClientM AvsPersonResponse -avsPersonStatus :: AvsStatusQuery -> ClientM AvsStatusResponse -(avsPersonSearch :<|> avsPersonStatus) = client avsApi (BasicAuthData "foo" "bar") --} - -{- --- Option 2: works, but requires yet another package: servant-flatten -type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus) -avsPersonSearch :: BasicAuthData -> AvsPersonQuery -> ClientM AvsPersonResponse -avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse -(avsPersonSearch :<|> avsPersonStatus) = client $ flatten avsApi --} - --- Option 3: -type AVS = AVSRoute AVSPersonSearch :<|> AVSRoute AVSPersonStatus -avsPersonSearch :: BasicAuthData -> AvsPersonQuery -> ClientM AvsPersonResponse -avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse -(avsPersonSearch :<|> avsPersonStatus) = client avsApi - - -runAvsPersonSearch :: AvsPersonQuery -> Import.Handler (Either Text AvsPersonResponse) -runAvsPersonSearch qry = do - manager <- getsYesod $ view _appHttpManager - mbAvsConf <- getsYesod $ view _appAvsConf - case mbAvsConf of - Nothing -> return $ Left "appAvsConfig is empty, i.e. invalid AVS configuration settings." - 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 - } - avsClient = mkClientEnv manager avsServer - fullQuery = avsPersonSearch avsAuth qry - liftIO $ over _Left tshow <$> runClientM fullQuery avsClient - -runAvsStatusSearch :: AvsStatusQuery -> Import.Handler (Either Text AvsStatusResponse) -runAvsStatusSearch qry = do - manager <- getsYesod $ view _appHttpManager - mbAvsConf <- getsYesod $ view _appAvsConf - case mbAvsConf of - Nothing -> return $ Left "appAvsConfig is empty, i.e. invalid AVS configuration settings." - Just avsConf -> do - -- TODO: consider using Servant.Client.Core.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 - } - avsClient = mkClientEnv manager avsServer - fullQuery = avsPersonStatus avsAuth qry - liftIO $ over _Left tshow <$> runClientM fullQuery avsClient - --- DEMO to check that it types -run :: IO () -run = do - manager' <- HTTP.newManager HTTP.defaultManagerSettings - let query = avsPersonSearch (BasicAuthData "foo" "bar") $ def { avsPersonQueryFirstName = Just "Steffen" } - res <- runClientM query (mkClientEnv manager' avsServer) - case res of - Left err -> putStrLn $ "Error: " ++ tshow err - Right resp -> do - print resp - where - avsServer :: BaseUrl - avsServer = BaseUrl - { baseUrlScheme = Https - , baseUrlHost = "skytest.fra.fraport.de" - , baseUrlPort = 80 - , baseUrlPath = "" - } diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs new file mode 100644 index 000000000..23f5ae4ea --- /dev/null +++ b/src/Utils/Avs.hs @@ -0,0 +1,56 @@ +module Utils.Avs where + +import Import.NoModel + +import Servant +import Servant.Client.Core (ClientError) + +import Utils.Lens + + +type AvsPersonResponse = Value +type AvsStatusResponse = Value + +data AvsPersonQuery = AvsPersonQuery + { avsPersonQueryCardNo :: Maybe Text + , avsPersonQueryFirstName :: Maybe Text + , avsPersonQueryLastName :: Maybe Text + , avsPersonQueryInternalPersonalNo :: Maybe Text + , avsPersonQueryVersionNo :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default AvsPersonQuery where + def = AvsPersonQuery Nothing Nothing Nothing Nothing Nothing + +deriveJSON defaultOptions + { fieldLabelModifier = mconcat . drop 3 . splitCamel + , omitNothingFields = True + , tagSingleConstructors = False + } ''AvsPersonQuery + + +newtype AvsStatusQuery = AvsStatusQuery (Set Int) +deriveJSON defaultOptions ''AvsStatusQuery + + +data AvsQuery = AvsQuery + { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse) + , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsStatusResponse) + } + +makeLenses_ ''AvsQuery + + +type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus) + +type AVSAuth = BasicAuth "avs_fradrive" String + +type AVSRoute a = AVSAuth :> "FraVSMService" :> "v1" :> a + +type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse +type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse + + +avsApi :: Proxy AVS +avsApi = Proxy