Skip to content

Commit f23dab8

Browse files
amesgenamesgen
authored
make the HTTP Manager configurable (#2027)
1 parent 70d494b commit f23dab8

File tree

11 files changed

+165
-50
lines changed

11 files changed

+165
-50
lines changed

‎cabal.project‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
packages: ./dhall ./dhall-bash ./dhall-json ./dhall-yaml ./dhall-lsp-server ./dhall-nix ./dhall-docs ./dhall-openapi
1+
packages: ./dhall ./dhall-bash ./dhall-json ./dhall-yaml ./dhall-lsp-server ./dhall-nix ./dhall-docs ./dhall-openapi ./dhall-nixpkgs

‎dhall/dhall.cabal‎

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -455,6 +455,12 @@ Flag with-http
455455
Default: True
456456
Manual: True
457457

458+
Flag use-http-client-tls
459+
Description: Use http-client-tls for resolving HTTP imports by default
460+
(requires with-http to be enabled)
461+
Default: True
462+
Manual: True
463+
458464
Flag cross
459465
Description: Disable TemplateHaskell to make cross-compiling easier
460466
Default: False
@@ -513,6 +519,9 @@ Library
513519
if flag(with-http)
514520
CPP-Options:
515521
-DWITH_HTTP
522+
if flag(use-http-client-tls)
523+
CPP-Options:
524+
-DUSE_HTTP_CLIENT_TLS
516525
if impl(ghcjs)
517526
Hs-Source-Dirs: ghcjs-src
518527
Build-Depends:
@@ -525,8 +534,10 @@ Library
525534
if flag(with-http)
526535
Build-Depends:
527536
http-types >= 0.7.0 && < 0.13,
528-
http-client >= 0.5.0 && < 0.8 ,
529-
http-client-tls >= 0.2.0 && < 0.4
537+
http-client >= 0.5.0 && < 0.8
538+
if flag(use-http-client-tls)
539+
Build-Depends:
540+
http-client-tls >= 0.2.0 && < 0.4
530541

531542
Other-Extensions:
532543
BangPatterns

‎dhall/doctest/Main.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ main = do
3333

3434
Test.DocTest.doctest
3535
[ "-DWITH_HTTP"
36+
, "-DUSE_HTTP_CLIENT_TLS"
3637
, "--fast"
3738
, prefix </> "ghc-src"
3839

‎dhall/ghc-src/Dhall/Import/HTTP.hs‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,6 @@ import Dhall.URL (renderURL)
2525
import Network.HTTP.Client
2626
( HttpException (..)
2727
, HttpExceptionContent (..)
28-
, Manager
2928
)
3029

3130
import qualified Control.Exception
@@ -37,7 +36,6 @@ import qualified Data.Text.Lazy
3736
import qualified Data.Text.Lazy.Encoding
3837
import qualified Dhall.Util
3938
import qualified Network.HTTP.Client as HTTP
40-
import qualified Network.HTTP.Client.TLS as HTTP
4139
import qualified Network.HTTP.Types
4240

4341
mkPrettyHttpException :: String -> HttpException -> PrettyHttpException
@@ -147,14 +145,11 @@ renderPrettyHttpException url (HttpExceptionRequest _ e) =
147145

148146
newManager :: StateT Status IO Manager
149147
newManager = do
150-
let settings = HTTP.tlsManagerSettings
151-
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds
152-
153148
Status { _manager = oldManager, ..} <- State.get
154149

155150
case oldManager of
156151
Nothing -> do
157-
manager <- liftIO (HTTP.newManager settings)
152+
manager <- liftIO _newManager
158153

159154
State.put (Status { _manager = Just manager , ..})
160155

‎dhall/ghc-src/Dhall/Import/Manager.hs‎

Lines changed: 18 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE CPP #-}
2+
13
{-| Both the GHC and GHCJS implementations of 'Dhall.Import.Manager.Manager'
24
export a `Dhall.Import.Manager.Manager` type suitable for use within the
35
"Dhall.Import" module
@@ -11,6 +13,21 @@
1113
module Dhall.Import.Manager
1214
( -- * Manager
1315
Manager
16+
, defaultNewManager
1417
) where
1518

16-
import Network.HTTP.Client (Manager)
19+
import Network.HTTP.Client (Manager, newManager)
20+
import qualified Network.HTTP.Client as HTTP
21+
22+
#ifdef USE_HTTP_CLIENT_TLS
23+
import Network.HTTP.Client.TLS (tlsManagerSettings)
24+
#endif
25+
26+
defaultNewManager :: IO Manager
27+
defaultNewManager = newManager
28+
#ifdef USE_HTTP_CLIENT_TLS
29+
tlsManagerSettings
30+
#else
31+
HTTP.defaultManagerSettings
32+
#endif
33+
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds

‎dhall/ghcjs-src/Dhall/Import/HTTP.hs‎

Lines changed: 1 addition & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -2,30 +2,19 @@
22

33
module Dhall.Import.HTTP
44
( fetchFromHttpUrl
5-
, Manager
65
) where
76

87
import Control.Monad.IO.Class (MonadIO (..))
98
import Control.Monad.Trans.State.Strict (StateT)
109
import Data.ByteString (ByteString)
1110
import Data.CaseInsensitive (CI)
12-
import Data.Void (Void)
1311
import Dhall.Core (URL (..))
14-
import Dhall.Import.Types
12+
import Dhall.Import.Types (Status)
1513
import Dhall.URL (renderURL)
1614

1715
import qualified Data.Text as Text
1816
import qualified JavaScript.XHR
1917

20-
21-
{-| The GHCJS implementation does not require a `Network.HTTP.Client.Manager`
22-
23-
The purpose of this synonym is so that "Dhall.Import.Types" can import a
24-
`Dhall.Import.Manager.Manager` type from "Dhall.Import.HTTP" that does the
25-
correct thing for both the GHC and GHCJS implementations
26-
-}
27-
type Manager = Void
28-
2918
fetchFromHttpUrl
3019
:: URL
3120
-> Maybe [(CI ByteString, ByteString)]

‎dhall/ghcjs-src/Dhall/Import/Manager.hs‎

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,16 @@
1111
module Dhall.Import.Manager
1212
( -- * Manager
1313
Manager
14+
, defaultNewManager
1415
) where
1516

16-
import Data.Void (Void)
17+
{-| The GHCJS implementation does not require a `Network.HTTP.Client.Manager`
1718
18-
-- | GHCJS does not use a `Network.HTTP.Client.Manager`
19-
type Manager = Void
19+
The purpose of this synonym is so that "Dhall.Import.Types" can import a
20+
`Dhall.Import.Manager.Manager` type from "Dhall.Import.HTTP" that does the
21+
correct thing for both the GHC and GHCJS implementations
22+
-}
23+
type Manager = ()
24+
25+
defaultNewManager :: IO Manager
26+
defaultNewManager = pure ()

‎dhall/src/Dhall.hs‎

Lines changed: 17 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ module Dhall
3737
, startingContext
3838
, substitutions
3939
, normalizer
40+
, newManager
4041
, defaultInputSettings
4142
, InputSettings
4243
, defaultEvaluateSettings
@@ -386,6 +387,7 @@ defaultInputSettings = InputSettings
386387
, _evaluateSettings = defaultEvaluateSettings
387388
}
388389

390+
389391
-- | Access the directory to resolve imports relative to.
390392
--
391393
-- @since 1.16
@@ -411,6 +413,7 @@ data EvaluateSettings = EvaluateSettings
411413
{ _substitutions :: Dhall.Substitution.Substitutions Src Void
412414
, _startingContext :: Dhall.Context.Context (Expr Src Void)
413415
, _normalizer :: Maybe (Core.ReifiedNormalizer Void)
416+
, _newManager :: IO Dhall.Import.Manager
414417
}
415418

416419
-- | Default evaluation settings: no extra entries in the initial
@@ -422,6 +425,7 @@ defaultEvaluateSettings = EvaluateSettings
422425
{ _substitutions = Dhall.Substitution.empty
423426
, _startingContext = Dhall.Context.empty
424427
, _normalizer = Nothing
428+
, _newManager = Dhall.Import.defaultNewManager
425429
}
426430

427431
-- | Access the starting context used for evaluation and type-checking.
@@ -460,6 +464,18 @@ normalizer = evaluateSettings . l
460464
=> LensLike' f EvaluateSettings (Maybe (Core.ReifiedNormalizer Void))
461465
l k s = fmap (\x -> s { _normalizer = x }) (k (_normalizer s))
462466

467+
-- | Access the HTTP manager initializer.
468+
--
469+
-- @since 1.36
470+
newManager
471+
:: (Functor f, HasEvaluateSettings s)
472+
=> LensLike' f s (IO Dhall.Import.Manager)
473+
newManager = evaluateSettings . l
474+
where
475+
l :: (Functor f)
476+
=> LensLike' f EvaluateSettings (IO Dhall.Import.Manager)
477+
l k s = fmap (\x -> s { _newManager = x }) (k (_newManager s))
478+
463479
-- | @since 1.16
464480
class HasEvaluateSettings s where
465481
evaluateSettings
@@ -623,7 +639,7 @@ inputHelper annotate settings txt = do
623639
. Lens.Family.set Dhall.Import.normalizer _normalizer
624640
. Lens.Family.set Dhall.Import.startingContext _startingContext
625641

626-
let status = transform (Dhall.Import.emptyStatus _rootDirectory)
642+
let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory)
627643

628644
expr' <- State.evalStateT (Dhall.Import.loadWith expr) status
629645

‎dhall/src/Dhall/Freeze.hs‎

Lines changed: 53 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,13 @@
88
module Dhall.Freeze
99
( -- * Freeze
1010
freeze
11+
, freezeWithManager
1112
, freezeExpression
13+
, freezeExpressionWithManager
1214
, freezeImport
15+
, freezeImportWithManager
1316
, freezeRemoteImport
17+
, freezeRemoteImportWithManager
1418

1519
-- * Types
1620
, Scope(..)
@@ -57,7 +61,15 @@ freezeImport
5761
-- ^ Current working directory
5862
-> Import
5963
-> IO Import
60-
freezeImport directory import_ = do
64+
freezeImport = freezeImportWithManager Dhall.Import.defaultNewManager
65+
66+
-- | See 'freezeImport'.
67+
freezeImportWithManager
68+
:: IO Dhall.Import.Manager
69+
-> FilePath
70+
-> Import
71+
-> IO Import
72+
freezeImportWithManager newManager directory import_ = do
6173
let unprotectedImport =
6274
import_
6375
{ importHashed =
@@ -66,7 +78,7 @@ freezeImport directory import_ = do
6678
}
6779
}
6880

69-
let status = Dhall.Import.emptyStatus directory
81+
let status = Dhall.Import.emptyStatusWithManager newManager directory
7082

7183
expression <- State.evalStateT (Dhall.Import.loadWith (Embed unprotectedImport)) status
7284

@@ -93,9 +105,17 @@ freezeRemoteImport
93105
-- ^ Current working directory
94106
-> Import
95107
-> IO Import
96-
freezeRemoteImport directory import_ =
108+
freezeRemoteImport = freezeRemoteImportWithManager Dhall.Import.defaultNewManager
109+
110+
-- | See 'freezeRemoteImport'.
111+
freezeRemoteImportWithManager
112+
:: IO Dhall.Import.Manager
113+
-> FilePath
114+
-> Import
115+
-> IO Import
116+
freezeRemoteImportWithManager newManager directory import_ =
97117
case importType (importHashed import_) of
98-
Remote {} -> freezeImport directory import_
118+
Remote {} -> freezeImportWithManager newManager directory import_
99119
_ -> return import_
100120

101121
-- | Specifies which imports to freeze
@@ -125,7 +145,19 @@ freeze
125145
-> CharacterSet
126146
-> Censor
127147
-> IO ()
128-
freeze outputMode input0 scope intent characterSet censor = go input0
148+
freeze = freezeWithManager Dhall.Import.defaultNewManager
149+
150+
-- | See 'freeze'.
151+
freezeWithManager
152+
:: IO Dhall.Import.Manager
153+
-> OutputMode
154+
-> PossiblyTransitiveInput
155+
-> Scope
156+
-> Intent
157+
-> CharacterSet
158+
-> Censor
159+
-> IO ()
160+
freezeWithManager newManager outputMode input0 scope intent characterSet censor = go input0
129161
where
130162
go input = do
131163
let directory = case input of
@@ -134,7 +166,7 @@ freeze outputMode input0 scope intent characterSet censor = go input0
134166
PossiblyTransitiveInputFile file _ ->
135167
System.FilePath.takeDirectory file
136168

137-
let status = Dhall.Import.emptyStatus directory
169+
let status = Dhall.Import.emptyStatusWithManager newManager directory
138170

139171
(originalText, transitivity) <- case input of
140172
PossiblyTransitiveInputFile file transitivity -> do
@@ -160,7 +192,7 @@ freeze outputMode input0 scope intent characterSet censor = go input0
160192
NonTransitive ->
161193
return ()
162194

163-
frozenExpression <- freezeExpression directory scope intent parsedExpression
195+
frozenExpression <- freezeExpressionWithManager newManager directory scope intent parsedExpression
164196

165197
let doc = Pretty.pretty header
166198
<> Dhall.Pretty.prettyCharacterSet characterSet frozenExpression
@@ -213,13 +245,23 @@ freezeExpression
213245
-> Intent
214246
-> Expr s Import
215247
-> IO (Expr s Import)
216-
freezeExpression directory scope intent expression = do
248+
freezeExpression = freezeExpressionWithManager Dhall.Import.defaultNewManager
249+
250+
-- | See 'freezeExpression'.
251+
freezeExpressionWithManager
252+
:: IO Dhall.Import.Manager
253+
-> FilePath
254+
-> Scope
255+
-> Intent
256+
-> Expr s Import
257+
-> IO (Expr s Import)
258+
freezeExpressionWithManager newManager directory scope intent expression = do
217259
let freezeScope =
218260
case scope of
219-
AllImports -> freezeImport
220-
OnlyRemoteImports -> freezeRemoteImport
261+
AllImports -> freezeImportWithManager
262+
OnlyRemoteImports -> freezeRemoteImportWithManager
221263

222-
let freezeFunction = freezeScope directory
264+
let freezeFunction = freezeScope newManager directory
223265

224266
let cache
225267
-- This case is necessary because `transformOf` is a bottom-up

0 commit comments

Comments
 (0)