[crypto] app executes properly now

parent 5dc1d983
...@@ -44,6 +44,7 @@ common defaults ...@@ -44,6 +44,7 @@ common defaults
, servant >= 0.20 && < 0.21 , servant >= 0.20 && < 0.21
, servant-client >= 0.20 && < 0.21 , servant-client >= 0.20 && < 0.21
, text >= 2.0.2 && < 2.2 , text >= 2.0.2 && < 2.2
ghc-options: -Wall -Wunused-imports -Wunused-binds -Wmissing-signatures -Werror
library library
import: import:
...@@ -58,6 +59,8 @@ library ...@@ -58,6 +59,8 @@ library
build-depends: build-depends:
bytestring >= 0.11.5 && < 0.15 bytestring >= 0.11.5 && < 0.15
, crypton-connection >= 0.4.2 && < 0.5 , crypton-connection >= 0.4.2 && < 0.5
, crypton-x509-store >= 1.6 && < 1.7
, crypton-x509-system >= 1.6 && < 1.7
, data-default-class >= 0.2 && < 0.3 , data-default-class >= 0.2 && < 0.3
, tls >= 2.1.7 && < 2.4 , tls >= 2.1.7 && < 2.4
default-language: Haskell2010 default-language: Haskell2010
......
...@@ -25,8 +25,6 @@ ...@@ -25,8 +25,6 @@
# `cabal`, `hlint` and `haskell-language-server` # `cabal`, `hlint` and `haskell-language-server`
shell.tools = { shell.tools = {
cabal = {}; cabal = {};
hlint = {};
haskell-language-server = {};
}; };
}; };
}) })
......
module ISTEX where module ISTEX where
import Data.ByteString qualified as B
import Data.Default.Class (def)
import Data.Text (Text)
import Data.X509.CertificateStore (CertificateStore)
import ISTEX.Client import ISTEX.Client
import Network.HTTP.Client (newManager) import Network.Connection (TLSSettings(..))
import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Client (ManagerSettings, newManager)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.TLS (ClientParams(..), EMSMode(AllowEMS), Supported(..), defaultParamsClient, sharedCAStore)
import Servant.Client import Servant.Client
import System.X509 (getSystemCertificateStore)
import Data.Text (Text)
runIstexAPIClient :: ClientM (Documents) -> IO (Either ClientError Documents) runIstexAPIClient :: ClientM (Documents) -> IO (Either ClientError Documents)
runIstexAPIClient cmd = do runIstexAPIClient cmd = do
manager' <- newManager tlsManagerSettings -- manager' <- newManager tlsManagerSettings
scs <- getSystemCertificateStore
manager' <- newManager $ getTLSManagerSettings scs
runClientM cmd (mkClientEnv manager' $ BaseUrl Https "api.istex.fr" 443 "document") runClientM cmd (mkClientEnv manager' $ BaseUrl Https "api.istex.fr" 443 "document")
-- | https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/456
getTLSManagerSettings :: CertificateStore -> ManagerSettings
getTLSManagerSettings scs = mkManagerSettings tlsSettings Nothing
where
tlsSettings = TLSSettings clientParams
-- See Network.Connection code on how `TLSSettings` is handled to make client params.
-- We need to change EMS and also apply system certificates, as they aren't in the defaults.
clientParams = (defaultParamsClient "" B.empty)
{ clientSupported = supported
, clientShared = def
{ sharedCAStore = scs }
}
supported = def { supportedExtendedMainSecret = AllowEMS }
getMetadataWith :: Text -> Maybe Int -> IO (Either ClientError Documents) getMetadataWith :: Text -> Maybe Int -> IO (Either ClientError Documents)
getMetadataWith q n = do getMetadataWith q n = do
runIstexAPIClient $ runIstexAPIClient $
...@@ -25,7 +47,9 @@ type ErrorHandler = ClientError -> IO () ...@@ -25,7 +47,9 @@ type ErrorHandler = ClientError -> IO ()
runIstexScrollAPIClient :: ClientM (ScrollResponse) -> IO (Either ClientError ScrollResponse) runIstexScrollAPIClient :: ClientM (ScrollResponse) -> IO (Either ClientError ScrollResponse)
runIstexScrollAPIClient cmd = do runIstexScrollAPIClient cmd = do
manager' <- newManager tlsManagerSettings -- manager' <- newManager tlsManagerSettings
scs <- getSystemCertificateStore
manager' <- newManager $ getTLSManagerSettings scs
runClientM cmd (mkClientEnv manager' $ BaseUrl Https "api.istex.fr" 443 "document") runClientM cmd (mkClientEnv manager' $ BaseUrl Https "api.istex.fr" 443 "document")
maxScrollPages :: Int maxScrollPages :: Int
...@@ -47,7 +71,7 @@ getMetadataScroll q scroll scrollId page = do ...@@ -47,7 +71,7 @@ getMetadataScroll q scroll scrollId page = do
scrollId scrollId
case eRes of case eRes of
Left err -> pure $ Left err Left err -> pure $ Left err
Right res@(ScrollResponse { .. }) -> do Right _res@(ScrollResponse { .. }) -> do
eDocs <- getMetadataScroll q scroll _scroll_scrollId (page + 1) eDocs <- getMetadataScroll q scroll _scroll_scrollId (page + 1)
case eDocs of case eDocs of
Left err -> pure $ Left err Left err -> pure $ Left err
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment