diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 16aa118..2864ca4 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -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 diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 2dc5fc7..9e6359c 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -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 diff --git a/dhall/src/Dhall/Import/HTTP.hs b/dhall/src/Dhall/Import/HTTP.hs index 76bde5f..8337e74 100644 --- a/dhall/src/Dhall/Import/HTTP.hs +++ b/dhall/src/Dhall/Import/HTTP.hs @@ -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 diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 72cec98..c784225 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -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 = diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 83d9179..b47bfe4 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -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 ()) ) diff --git a/dhall/tests/Dhall/Test/TypeCheck.hs b/dhall/tests/Dhall/Test/TypeCheck.hs index 4d409d4..6f483a6 100644 --- a/dhall/tests/Dhall/Test/TypeCheck.hs +++ b/dhall/tests/Dhall/Test/TypeCheck.hs @@ -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 diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 762f4bf..928c8b2 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -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) diff --git a/nix/shared.nix b/nix/shared.nix index 46f395c..3ebb113 100644 --- a/nix/shared.nix +++ b/nix/shared.nix @@ -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; diff --git a/release.nix b/release.nix index 9ddd21e..5a83146 100644 --- a/release.nix +++ b/release.nix @@ -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) ]; };