feat(avs): disable certificate validation for avs api
This commit is contained in:
Sarah Vaupel
parent
3be0cf95aa
commit
66dd1a8b70
@ -121,6 +121,7 @@ dependencies:
|
||||
- semigroupoids
|
||||
- http-types
|
||||
- http-client
|
||||
- http-client-tls
|
||||
- jose-jwt
|
||||
- mono-traversable
|
||||
- mono-traversable-keys
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = ""
|
||||
}
|
||||
56
src/Utils/Avs.hs
Normal file
56
src/Utils/Avs.hs
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user