Fix tests without `with-http` flag (#1159)
* Allow customization of remote import resolution
Makes the `Status` type more general; previously support for
`Network.HTTP.Client` was hardcoded. In short:
```
data Status = Status
{ _stack :: NonEmpty Chained
[...]
-- , _manager :: Maybe Dynamic
-- -- importing the same expression twice with different values
++ , _remote :: URL -> StateT Status IO Data.Text.Text
++ -- ^ The remote resolver, fetches the content at the given URL.
[...]
}
```
* Simplify and expose `toHeaders`
`toHeaders` will be needed for mock http testing
* Fix compilation without `with-http` flag
* Fix compilation with `with-http` flag
* Fix tests without `with-http` flag
Implements a mock http client that handles requests to:
- `https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/`
- `https://test.dhall-lang.org/Bool/package.dhall`
- `https://httpbin.org/user-agent`
This allows tests involving remote imports to succeed even when compiled
without the `with-http` flag.
* Build `dhall` with HTTP support compiled out in CI
... to prevent regressions from occurring in the future
This commit is contained in:
Frederik Ramcke
mergify[bot]
parent
5bb84cbd94
commit
fd8683216d
|
|
@ -686,6 +686,7 @@ Test-Suite tasty
|
|||
directory ,
|
||||
filepath ,
|
||||
foldl < 1.5 ,
|
||||
lens-family-core >= 1.0.0 && < 2.1 ,
|
||||
megaparsec ,
|
||||
prettyprinter ,
|
||||
QuickCheck >= 2.10 && < 2.14,
|
||||
|
|
@ -700,6 +701,9 @@ Test-Suite tasty
|
|||
transformers ,
|
||||
turtle < 1.6 ,
|
||||
vector >= 0.11.0.0 && < 0.13
|
||||
if flag(with-http)
|
||||
CPP-Options:
|
||||
-DWITH_HTTP
|
||||
Default-Language: Haskell2010
|
||||
|
||||
Test-Suite doctest
|
||||
|
|
|
|||
|
|
@ -117,7 +117,8 @@ module Dhall.Import (
|
|||
, cache
|
||||
, Depends(..)
|
||||
, graph
|
||||
, manager
|
||||
, remote
|
||||
, toHeaders
|
||||
, standardVersion
|
||||
, normalizer
|
||||
, startingContext
|
||||
|
|
@ -169,6 +170,7 @@ import Dhall.Core
|
|||
, URL(..)
|
||||
)
|
||||
#ifdef MIN_VERSION_http_client
|
||||
import Network.HTTP.Client (Manager)
|
||||
import Dhall.Import.HTTP hiding (HTTPHeader)
|
||||
#endif
|
||||
import Dhall.Import.Types
|
||||
|
|
@ -397,29 +399,6 @@ instance Canonicalize Import where
|
|||
canonicalize (Import importHashed importMode) =
|
||||
Import (canonicalize importHashed) importMode
|
||||
|
||||
-- Given a well-typed (of type `List { header : Text, value Text }` or
|
||||
-- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form
|
||||
-- construct the corresponding binary http headers.
|
||||
toHeaders :: Expr s a -> Maybe [HTTPHeader]
|
||||
toHeaders (ListLit _ hs) = do
|
||||
hs' <- mapM toHeader hs
|
||||
return (Data.Foldable.toList hs')
|
||||
toHeaders _ = do
|
||||
empty
|
||||
|
||||
toHeader :: Expr s a -> Maybe HTTPHeader
|
||||
toHeader (RecordLit m) = do
|
||||
TextLit (Chunks [] keyText ) <-
|
||||
Dhall.Map.lookup "header" m <|> Dhall.Map.lookup "mapKey" m
|
||||
TextLit (Chunks [] valueText) <-
|
||||
Dhall.Map.lookup "value" m <|> Dhall.Map.lookup "mapValue" m
|
||||
let keyBytes = Data.Text.Encoding.encodeUtf8 keyText
|
||||
let valueBytes = Data.Text.Encoding.encodeUtf8 valueText
|
||||
return (Data.CaseInsensitive.mk keyBytes, valueBytes)
|
||||
toHeader _ = do
|
||||
empty
|
||||
|
||||
|
||||
-- | Exception thrown when an integrity check fails
|
||||
data HashMismatch = HashMismatch
|
||||
{ expectedHash :: Crypto.Hash.Digest SHA256
|
||||
|
|
@ -663,9 +642,9 @@ loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Loc
|
|||
local@(Local _ _) ->
|
||||
App (Field locationType "Local")
|
||||
(TextLit (Chunks [] (Dhall.Pretty.Internal.pretty local)))
|
||||
remote@(Remote _) ->
|
||||
remote_@(Remote _) ->
|
||||
App (Field locationType "Remote")
|
||||
(TextLit (Chunks [] (Dhall.Pretty.Internal.pretty remote)))
|
||||
(TextLit (Chunks [] (Dhall.Pretty.Internal.pretty remote_)))
|
||||
Env env ->
|
||||
App (Field locationType "Environment")
|
||||
(TextLit (Chunks [] (Dhall.Pretty.Internal.pretty env)))
|
||||
|
|
@ -704,16 +683,9 @@ fetchFresh (Local prefix file) = do
|
|||
then liftIO $ Data.Text.IO.readFile path
|
||||
else throwMissingImport (Imported _stack (MissingFile path))
|
||||
|
||||
fetchFresh (Remote (url@URL { headers = maybeHeadersExpression })) = do
|
||||
#ifdef MIN_VERSION_http_client
|
||||
let maybeHeaders = foldMap toHeaders maybeHeadersExpression
|
||||
fetchFromHttpUrl url maybeHeaders
|
||||
#else
|
||||
let maybeHeaders = foldMap toHeaders maybeHeadersExpression
|
||||
let urlString = Text.unpack (Dhall.Core.pretty url)
|
||||
Status { _stack } <- State.get
|
||||
throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders))
|
||||
#endif
|
||||
fetchFresh (Remote url) = do
|
||||
Status { _remote } <- State.get
|
||||
_remote url
|
||||
|
||||
fetchFresh (Env env) = do
|
||||
Status { _stack } <- State.get
|
||||
|
|
@ -726,6 +698,48 @@ fetchFresh (Env env) = do
|
|||
|
||||
fetchFresh Missing = throwM (MissingImports [])
|
||||
|
||||
|
||||
fetchRemote :: URL -> StateT Status IO Data.Text.Text
|
||||
#ifndef MIN_VERSION_http_client
|
||||
fetchRemote (url@URL { headers = maybeHeadersExpression }) = do
|
||||
let maybeHeaders = fmap toHeaders maybeHeadersExpression
|
||||
let urlString = Text.unpack (Dhall.Core.pretty url)
|
||||
Status { _stack } <- State.get
|
||||
throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders))
|
||||
#else
|
||||
fetchRemote url = do
|
||||
manager <- liftIO $ newManager
|
||||
zoom remote (State.put (fetchFromHTTP manager))
|
||||
fetchFromHTTP manager url
|
||||
where
|
||||
fetchFromHTTP :: Manager -> URL -> StateT Status IO Data.Text.Text
|
||||
fetchFromHTTP manager (url'@URL { headers = maybeHeadersExpression }) = do
|
||||
let maybeHeaders = fmap toHeaders maybeHeadersExpression
|
||||
fetchFromHttpUrl manager url' maybeHeaders
|
||||
#endif
|
||||
|
||||
-- | Given a well-typed (of type `List { header : Text, value Text }` or
|
||||
-- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form
|
||||
-- construct the corresponding binary http headers; otherwise return the empty
|
||||
-- list.
|
||||
toHeaders :: Expr s a -> [HTTPHeader]
|
||||
toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders)
|
||||
where
|
||||
maybeHeaders = mapM toHeader hs
|
||||
toHeaders _ = []
|
||||
|
||||
toHeader :: Expr s a -> Maybe HTTPHeader
|
||||
toHeader (RecordLit m) = do
|
||||
TextLit (Chunks [] keyText ) <-
|
||||
Dhall.Map.lookup "header" m <|> Dhall.Map.lookup "mapKey" m
|
||||
TextLit (Chunks [] valueText) <-
|
||||
Dhall.Map.lookup "value" m <|> Dhall.Map.lookup "mapValue" m
|
||||
let keyBytes = Data.Text.Encoding.encodeUtf8 keyText
|
||||
let valueBytes = Data.Text.Encoding.encodeUtf8 valueText
|
||||
return (Data.CaseInsensitive.mk keyBytes, valueBytes)
|
||||
toHeader _ = do
|
||||
empty
|
||||
|
||||
getCacheFile
|
||||
:: (Alternative m, MonadIO m) => FilePath -> Crypto.Hash.Digest SHA256 -> m FilePath
|
||||
getCacheFile cacheName hash = do
|
||||
|
|
@ -832,6 +846,10 @@ normalizeHeaders url@URL { headers = Just headersExpression } = do
|
|||
|
||||
normalizeHeaders url = return url
|
||||
|
||||
-- | Default starting `Status`, importing relative to the given directory.
|
||||
emptyStatus :: FilePath -> Status
|
||||
emptyStatus = emptyStatusWith fetchRemote
|
||||
|
||||
{-| Generalized version of `load`
|
||||
|
||||
You can configure the desired behavior through the initial `Status` that you
|
||||
|
|
|
|||
|
|
@ -5,15 +5,13 @@
|
|||
module Dhall.Import.HTTP where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.Dynamic (fromDynamic, toDyn)
|
||||
import Data.Dynamic (toDyn)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Text (Text)
|
||||
import Lens.Family.State.Strict (zoom)
|
||||
|
||||
import Dhall.Core
|
||||
( Directory(..)
|
||||
|
|
@ -109,24 +107,17 @@ renderPrettyHttpException e = case e of
|
|||
<> show e'
|
||||
#endif
|
||||
|
||||
needManager :: StateT Status IO Manager
|
||||
needManager = do
|
||||
x <- zoom manager State.get
|
||||
case join (fmap fromDynamic x) of
|
||||
Just m -> return m
|
||||
Nothing -> do
|
||||
let settings = HTTP.tlsManagerSettings
|
||||
|
||||
newManager :: IO Manager
|
||||
newManager = do
|
||||
let settings = HTTP.tlsManagerSettings
|
||||
#ifdef MIN_VERSION_http_client
|
||||
#if MIN_VERSION_http_client(0,5,0)
|
||||
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds
|
||||
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds
|
||||
#else
|
||||
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds
|
||||
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds
|
||||
#endif
|
||||
#endif
|
||||
m <- liftIO (HTTP.newManager settings)
|
||||
zoom manager (State.put (Just (toDyn m)))
|
||||
return m
|
||||
HTTP.newManager settings
|
||||
|
||||
data NotCORSCompliant = NotCORSCompliant
|
||||
{ expectedOrigins :: [ByteString]
|
||||
|
|
@ -235,11 +226,12 @@ renderURL url =
|
|||
type HTTPHeader = Network.HTTP.Types.Header
|
||||
|
||||
fetchFromHttpUrl
|
||||
:: URL
|
||||
:: Manager
|
||||
-> URL
|
||||
-> Maybe [HTTPHeader]
|
||||
-> StateT Status IO Text.Text
|
||||
#ifdef __GHCJS__
|
||||
fetchFromHttpUrl childURL Nothing = do
|
||||
fetchFromHttpUrl _ childURL Nothing = do
|
||||
let childURLText = renderURL childURL
|
||||
|
||||
let childURLString = Text.unpack childURLText
|
||||
|
|
@ -253,14 +245,12 @@ fetchFromHttpUrl childURL Nothing = do
|
|||
_ -> fail (childURLString <> " returned a non-200 status code: " <> show statusCode)
|
||||
|
||||
return body
|
||||
fetchFromHttpUrl _ _ = do
|
||||
fetchFromHttpUrl _ _ _ = do
|
||||
fail "Dhall does not yet support custom headers when built using GHCJS"
|
||||
#else
|
||||
fetchFromHttpUrl childURL mheaders = do
|
||||
fetchFromHttpUrl manager childURL mheaders = do
|
||||
let childURLString = Text.unpack (renderURL childURL)
|
||||
|
||||
m <- needManager
|
||||
|
||||
request <- liftIO (HTTP.parseUrlThrow childURLString)
|
||||
|
||||
let requestWithHeaders =
|
||||
|
|
@ -268,7 +258,7 @@ fetchFromHttpUrl childURL mheaders = do
|
|||
Nothing -> request
|
||||
Just headers -> request { HTTP.requestHeaders = headers }
|
||||
|
||||
let io = HTTP.httpLbs requestWithHeaders m
|
||||
let io = HTTP.httpLbs requestWithHeaders manager
|
||||
|
||||
let handler e = do
|
||||
let _ = e :: HttpException
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
module Dhall.Import.Types where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
import Data.Dynamic
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map (Map)
|
||||
|
|
@ -22,6 +23,7 @@ import Dhall.Core
|
|||
, ImportMode (..)
|
||||
, ImportType (..)
|
||||
, ReifiedNormalizer(..)
|
||||
, URL
|
||||
)
|
||||
import Dhall.Parser (Src)
|
||||
import Dhall.TypeCheck (X)
|
||||
|
|
@ -66,8 +68,8 @@ data Status = Status
|
|||
-- ^ Cache of imported expressions with their node id in order to avoid
|
||||
-- importing the same expression twice with different values
|
||||
|
||||
, _manager :: Maybe Dynamic
|
||||
-- ^ Cache for the HTTP `Manager` so that we only acquire it once
|
||||
, _remote :: URL -> StateT Status IO Data.Text.Text
|
||||
-- ^ The remote resolver, fetches the content at the given URL.
|
||||
|
||||
, _standardVersion :: StandardVersion
|
||||
|
||||
|
|
@ -76,9 +78,10 @@ data Status = Status
|
|||
, _startingContext :: Context (Expr Src X)
|
||||
}
|
||||
|
||||
-- | Default starting `Status`, importing relative to the given directory.
|
||||
emptyStatus :: FilePath -> Status
|
||||
emptyStatus rootDirectory = Status {..}
|
||||
-- | Initial `Status`, parameterised over the remote resolver, importing
|
||||
-- relative to the given directory.
|
||||
emptyStatusWith :: (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status
|
||||
emptyStatusWith _remote rootDirectory = Status {..}
|
||||
where
|
||||
_stack = pure (Chained rootImport)
|
||||
|
||||
|
|
@ -120,8 +123,8 @@ graph k s = fmap (\x -> s { _graph = x }) (k (_graph s))
|
|||
cache :: Functor f => LensLike' f Status (Map Chained ImportSemantics)
|
||||
cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))
|
||||
|
||||
manager :: Functor f => LensLike' f Status (Maybe Dynamic)
|
||||
manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))
|
||||
remote :: Functor f => LensLike' f Status (URL -> StateT Status IO Data.Text.Text)
|
||||
remote k s = fmap (\x -> s { _remote = x }) (k (_remote s))
|
||||
|
||||
standardVersion :: Functor f => LensLike' f Status StandardVersion
|
||||
standardVersion k s =
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ successTest path = do
|
|||
let unsetCache = Turtle.unset "XDG_CACHE_HOME"
|
||||
|
||||
let load =
|
||||
State.evalStateT (Import.loadWith actualExpr) (Import.emptyStatus directoryString)
|
||||
State.evalStateT (Test.Util.loadWith actualExpr) (Import.emptyStatus directoryString)
|
||||
|
||||
if Turtle.filename (Turtle.fromText path) == "hashFromCacheA.dhall"
|
||||
then do
|
||||
|
|
@ -81,7 +81,7 @@ failureTest path = do
|
|||
actualExpr <- Core.throws (Parser.exprFromText mempty text)
|
||||
|
||||
Exception.catch
|
||||
(do _ <- Import.load actualExpr
|
||||
(do _ <- Test.Util.load actualExpr
|
||||
|
||||
fail "Import should have failed, but it succeeds")
|
||||
(\(SourcedException _ (MissingImports _)) -> pure ()) )
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@ import qualified Control.Exception as Exception
|
|||
import qualified Control.Monad as Monad
|
||||
import qualified Data.Text as Text
|
||||
import qualified Dhall.Core as Core
|
||||
import qualified Dhall.Import as Import
|
||||
import qualified Dhall.Parser as Parser
|
||||
import qualified Dhall.Test.Util as Test.Util
|
||||
import qualified Dhall.TypeCheck as TypeCheck
|
||||
|
|
@ -58,7 +57,7 @@ successTest prefix =
|
|||
|
||||
let annotatedExpr = Core.Annot actualExpr expectedExpr
|
||||
|
||||
resolvedExpr <- Import.load annotatedExpr
|
||||
resolvedExpr <- Test.Util.load annotatedExpr
|
||||
|
||||
_ <- Core.throws (TypeCheck.typeOf resolvedExpr)
|
||||
|
||||
|
|
@ -73,7 +72,7 @@ failureTest path = do
|
|||
|
||||
let io :: IO Bool
|
||||
io = do
|
||||
_ <- Import.load expression
|
||||
_ <- Test.Util.load expression
|
||||
return True
|
||||
|
||||
let handler :: SomeException -> IO Bool
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Dhall.Test.Util
|
||||
( code
|
||||
, codeWith
|
||||
, equivalent
|
||||
, load
|
||||
, loadWith
|
||||
, normalize'
|
||||
, normalizeWith'
|
||||
, assertNormalizesTo
|
||||
|
|
@ -16,10 +19,12 @@ module Dhall.Test.Util
|
|||
, toDhallPath
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Text (Text)
|
||||
import Dhall.Context (Context)
|
||||
import Dhall.Core (Expr, Normalizer, ReifiedNormalizer(..))
|
||||
import Dhall.Core (Expr, Normalizer, ReifiedNormalizer(..), Import)
|
||||
import Dhall.Import (Status)
|
||||
import Dhall.Parser (Src)
|
||||
import Dhall.TypeCheck (X)
|
||||
import Prelude hiding (FilePath)
|
||||
|
|
@ -36,9 +41,20 @@ import qualified Dhall.Core
|
|||
import qualified Dhall.Import
|
||||
import qualified Dhall.Parser
|
||||
import qualified Dhall.TypeCheck
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Test.Tasty as Tasty
|
||||
import qualified Turtle
|
||||
|
||||
#ifndef WITH_HTTP
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Dhall.Core (URL(..))
|
||||
import Lens.Family.State.Strict (zoom)
|
||||
|
||||
import qualified Data.Foldable
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Text.IO
|
||||
#endif
|
||||
|
||||
normalize' :: Expr Src X -> Text
|
||||
normalize' = Dhall.Core.pretty . Dhall.Core.normalize
|
||||
|
||||
|
|
@ -54,12 +70,79 @@ codeWith ctx expr = do
|
|||
expr0 <- case Dhall.Parser.exprFromText mempty expr of
|
||||
Left parseError -> Control.Exception.throwIO parseError
|
||||
Right expr0 -> return expr0
|
||||
expr1 <- Dhall.Import.load expr0
|
||||
expr1 <- load expr0
|
||||
case Dhall.TypeCheck.typeWith ctx expr1 of
|
||||
Left typeError -> Control.Exception.throwIO typeError
|
||||
Right _ -> return ()
|
||||
return expr1
|
||||
|
||||
load :: Expr Src Import -> IO (Expr Src X)
|
||||
load expression =
|
||||
State.evalStateT (loadWith expression) (Dhall.Import.emptyStatus ".")
|
||||
|
||||
#ifdef WITH_HTTP
|
||||
loadWith :: Expr Src Import -> StateT Status IO (Expr Src X)
|
||||
loadWith = Dhall.Import.loadWith
|
||||
|
||||
#else
|
||||
loadWith :: Expr Src Import -> StateT Status IO (Expr Src X)
|
||||
loadWith expr = do
|
||||
let mockRemote' url = do
|
||||
liftIO . putStrLn $ "\nTesting without real HTTP support --"
|
||||
++ " using mock HTTP client to resolve remote import."
|
||||
mockRemote url
|
||||
zoom Dhall.Import.remote (State.put mockRemote')
|
||||
Dhall.Import.loadWith expr
|
||||
|
||||
mockRemote :: Dhall.Core.URL -> StateT Status IO Data.Text.Text
|
||||
-- Matches anything pointing to
|
||||
-- `https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/`
|
||||
mockRemote (URL { authority = "raw.githubusercontent.com"
|
||||
, path = Dhall.Core.File (Dhall.Core.Directory components) file })
|
||||
| take 3 (reverse components) == ["dhall-lang", "dhall-lang", "master"] = do
|
||||
let dropEnd n ls = take (length ls - n) ls
|
||||
let localDir = dropEnd 3 components ++ ["dhall-lang"]
|
||||
|
||||
localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file)
|
||||
liftIO $ Data.Text.IO.readFile localPath
|
||||
|
||||
-- Matches anything pointing to
|
||||
-- `https://test.dhall-lang.org/Bool/package.dhall`; checks that a `test` header
|
||||
-- is present and redirects to the local copy of the prelude.
|
||||
mockRemote (URL { authority = "test.dhall-lang.org"
|
||||
, path = Dhall.Core.File (Dhall.Core.Directory components) file
|
||||
, headers = Just headersExpr }) =
|
||||
case Data.Foldable.find ((== "test") . fst) hs of
|
||||
Nothing -> fail $ "(mock http) Tried to load an import from "
|
||||
++"\"test.dhall-lang.org\""
|
||||
++ "without setting the \"test\" header field."
|
||||
Just (_, _) -> do
|
||||
let localDir = components ++ ["Prelude", "dhall-lang"]
|
||||
localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file)
|
||||
liftIO $ Data.Text.IO.readFile localPath
|
||||
where
|
||||
hs = Dhall.Import.toHeaders headersExpr
|
||||
|
||||
-- Emulates `https://httpbin.org/user-agent`
|
||||
mockRemote (URL { authority = "httpbin.org"
|
||||
, path = Dhall.Core.File (Dhall.Core.Directory []) "user-agent"
|
||||
, headers = Just headersExpr }) =
|
||||
case Data.Foldable.find ((== "user-agent") . fst) hs of
|
||||
Nothing -> fail $ "(mock http) Tried to read the user agent via "
|
||||
++ "\"httpbin.com/user-agent\" without supplying one "
|
||||
++ "in the header!"
|
||||
Just (_, userAgent) -> do
|
||||
let agentText = Data.Text.Encoding.decodeUtf8 userAgent
|
||||
return ("{\n \"user-agent\": \"" <> agentText <> "\"\n}\n")
|
||||
where
|
||||
hs = Dhall.Import.toHeaders headersExpr
|
||||
|
||||
mockRemote url = do
|
||||
let urlString = Text.unpack (Dhall.Core.pretty url)
|
||||
fail ("(mock http) Url does not match any of the hard-coded rules: "
|
||||
<> urlString)
|
||||
#endif
|
||||
|
||||
equivalent :: Text -> Text -> IO ()
|
||||
equivalent text0 text1 = do
|
||||
expr0 <- fmap Dhall.Core.normalize (code text0) :: IO (Expr X X)
|
||||
|
|
@ -93,7 +176,7 @@ assertDoesntTypeCheck text = do
|
|||
expr0 <- case Dhall.Parser.exprFromText mempty text of
|
||||
Left parseError -> Control.Exception.throwIO parseError
|
||||
Right e -> return e
|
||||
expr1 <- Dhall.Import.load expr0
|
||||
expr1 <- load expr0
|
||||
case Dhall.TypeCheck.typeOf expr1 of
|
||||
Left _ -> return ()
|
||||
Right type_ -> fail ("Bad type for " <> Text.unpack text <> "\n " <> show type_)
|
||||
|
|
@ -104,9 +187,9 @@ assertDoesntTypeCheck text = do
|
|||
discover :: Pattern Text -> (Text -> TestTree) -> Shell FilePath -> IO TestTree
|
||||
discover pattern buildTest paths = do
|
||||
let shell = do
|
||||
path <- paths
|
||||
path_ <- paths
|
||||
|
||||
let pathText = Turtle.format fp path
|
||||
let pathText = Turtle.format fp path_
|
||||
|
||||
prefix : _ <- return (Turtle.match pattern pathText)
|
||||
|
||||
|
|
|
|||
|
|
@ -169,6 +169,11 @@ let
|
|||
{ }
|
||||
);
|
||||
|
||||
dhall-no-http =
|
||||
pkgsNew.haskell.lib.appendConfigureFlag
|
||||
haskellPackagesNew.dhall
|
||||
[ "-f-with-http" ];
|
||||
|
||||
dhall-bash =
|
||||
haskellPackagesNew.callCabal2nix
|
||||
"dhall-bash"
|
||||
|
|
@ -612,7 +617,15 @@ in
|
|||
|
||||
inherit (pkgs) tarball-website website;
|
||||
|
||||
inherit (pkgs.haskell.packages."${compiler}") dhall dhall-bash dhall-json dhall-lsp-server dhall-nix dhall-try;
|
||||
inherit (pkgs.haskell.packages."${compiler}")
|
||||
dhall
|
||||
dhall-no-http
|
||||
dhall-bash
|
||||
dhall-json
|
||||
dhall-lsp-server
|
||||
dhall-nix
|
||||
dhall-try
|
||||
;
|
||||
|
||||
inherit (pkgs.releaseTools) aggregate;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,6 +60,9 @@ in
|
|||
coverage.dhall
|
||||
coverage.dhall-json
|
||||
|
||||
# Check that the package builds with HTTP support compiled out
|
||||
shared.dhall-no-http
|
||||
|
||||
(shared.trivial src.rev)
|
||||
];
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in New Issue