feat(avs): disable certificate validation for avs api

package.yaml

@@ -121,6 +121,7 @@ dependencies:
   - semigroupoids
   - http-types
   - http-client
+  - http-client-tls
   - jose-jwt
   - mono-traversable
   - mono-traversable-keys

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 {..}
+      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = 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
       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"

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

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 
+          Left err -> return . Just $ tshow err
-          Right jsn -> return $ Just $ tshow jsn         
+          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 
+          Left err -> return . Just $ tshow err 
-          Right jsn -> return $ Just $ tshow jsn         
+          Right jsn -> return . Just $ tshow jsn         
   mbStatus <- formResultMaybe sresult procFormStatus
 
   actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute

src/Handler/Utils/Servant/Avs.hs

@@ -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   = ""
-      }

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