fd8683216d
* 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
283 lines
8.8 KiB
Haskell
283 lines
8.8 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Dhall.Import.HTTP where
|
|
|
|
import Control.Exception (Exception)
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
|
import Control.Monad.Trans.State.Strict (StateT)
|
|
import Data.ByteString (ByteString)
|
|
import Data.CaseInsensitive (CI)
|
|
import Data.Dynamic (toDyn)
|
|
import Data.Semigroup ((<>))
|
|
import Data.Text (Text)
|
|
|
|
import Dhall.Core
|
|
( Directory(..)
|
|
, File(..)
|
|
, Import(..)
|
|
, ImportHashed(..)
|
|
, ImportType(..)
|
|
, Scheme(..)
|
|
, URL(..)
|
|
)
|
|
|
|
import qualified Control.Monad.Trans.State.Strict as State
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding
|
|
import qualified Dhall.Util
|
|
import qualified Network.URI.Encode as URI.Encode
|
|
|
|
import Dhall.Import.Types
|
|
|
|
import qualified Control.Exception
|
|
#ifdef __GHCJS__
|
|
import qualified JavaScript.XHR
|
|
#else
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import qualified Data.Text.Lazy
|
|
import qualified Data.Text.Lazy.Encoding
|
|
#endif
|
|
|
|
#if MIN_VERSION_http_client(0,5,0)
|
|
import Network.HTTP.Client
|
|
(HttpException(..), HttpExceptionContent(..), Manager)
|
|
#else
|
|
import Network.HTTP.Client (HttpException(..), Manager)
|
|
#endif
|
|
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Client.TLS as HTTP
|
|
import qualified Network.HTTP.Types
|
|
|
|
mkPrettyHttpException :: HttpException -> PrettyHttpException
|
|
mkPrettyHttpException ex =
|
|
PrettyHttpException (renderPrettyHttpException ex) (toDyn ex)
|
|
|
|
renderPrettyHttpException :: HttpException -> String
|
|
#if MIN_VERSION_http_client(0,5,0)
|
|
renderPrettyHttpException (InvalidUrlException _ r) =
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Invalid URL\n"
|
|
<> "\n"
|
|
<> "↳ " <> show r
|
|
renderPrettyHttpException (HttpExceptionRequest _ e) =
|
|
case e of
|
|
ConnectionFailure _ ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Remote host not found\n"
|
|
InvalidDestinationHost host ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Invalid remote host name\n"
|
|
<> "\n"
|
|
<> "↳ " <> show host
|
|
ResponseTimeout ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: The remote host took too long to respond"
|
|
StatusCodeException response _
|
|
| statusCode == 404 ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Remote file not found"
|
|
| otherwise ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Unexpected HTTP status code:\n"
|
|
<> "\n"
|
|
<> "↳ " <> show statusCode
|
|
where
|
|
statusCode =
|
|
Network.HTTP.Types.statusCode
|
|
(HTTP.responseStatus response)
|
|
e' -> "\n" <> show e'
|
|
#else
|
|
renderPrettyHttpException e = case e of
|
|
FailedConnectionException2 _ _ _ e' ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Wrong host\n"
|
|
<> "\n"
|
|
<> "↳ " <> show e'
|
|
InvalidDestinationHost host ->
|
|
"\n"
|
|
<> "\ESC[1;31mError\ESC[0m: Invalid host name\n"
|
|
<> "\n"
|
|
<> "↳ " <> show host
|
|
ResponseTimeout ->
|
|
"\ESC[1;31mError\ESC[0m: The host took too long to respond\n"
|
|
e' -> "\n"
|
|
<> show e'
|
|
#endif
|
|
|
|
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
|
|
#else
|
|
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds
|
|
#endif
|
|
#endif
|
|
HTTP.newManager settings
|
|
|
|
data NotCORSCompliant = NotCORSCompliant
|
|
{ expectedOrigins :: [ByteString]
|
|
, actualOrigin :: ByteString
|
|
}
|
|
|
|
instance Exception NotCORSCompliant
|
|
|
|
instance Show NotCORSCompliant where
|
|
show (NotCORSCompliant {..}) =
|
|
Dhall.Util._ERROR <> ": Not CORS compliant\n"
|
|
<> "\n"
|
|
<> "Dhall supports transitive imports, meaning that an imported expression can\n"
|
|
<> "import other expressions. However, a remote import (the \"parent\" import)\n"
|
|
<> "cannot import another remote import (the \"child\" import) unless the child\n"
|
|
<> "import grants permission to do using CORS. The child import must respond with\n"
|
|
<> "an `Access-Control-Allow-Origin` response header that matches the parent\n"
|
|
<> "import, otherwise Dhall rejects the import.\n"
|
|
<> "\n" <> prologue
|
|
where
|
|
prologue =
|
|
case expectedOrigins of
|
|
[ expectedOrigin ] ->
|
|
"The following parent import:\n"
|
|
<> "\n"
|
|
<> "↳ " <> show actualOrigin <> "\n"
|
|
<> "\n"
|
|
<> "... did not match the expected origin:\n"
|
|
<> "\n"
|
|
<> "↳ " <> show expectedOrigin <> "\n"
|
|
<> "\n"
|
|
<> "... so import resolution failed.\n"
|
|
[] ->
|
|
"The child response did not include any `Access-Control-Allow-Origin` header,\n"
|
|
<> "so import resolution failed.\n"
|
|
_:_:_ ->
|
|
"The child response included more than one `Access-Control-Allow-Origin` header,\n"
|
|
<> "when only one such header should have been present, so import resolution\n"
|
|
<> "failed.\n"
|
|
<> "\n"
|
|
<> "This may indicate that the server for the child import is misconfigured.\n"
|
|
|
|
corsCompliant
|
|
:: MonadIO io
|
|
=> ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
|
|
corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do
|
|
let toOrigin (URL {..}) =
|
|
Data.Text.Encoding.encodeUtf8 (prefix <> "://" <> authority)
|
|
where
|
|
prefix =
|
|
case scheme of
|
|
HTTP -> "http"
|
|
HTTPS -> "https"
|
|
|
|
let actualOrigin = toOrigin parentURL
|
|
|
|
let childOrigin = toOrigin childURL
|
|
|
|
let predicate (header, _) = header == "Access-Control-Allow-Origin"
|
|
|
|
let originHeaders = filter predicate responseHeaders
|
|
|
|
let expectedOrigins = map snd originHeaders
|
|
|
|
case expectedOrigins of
|
|
[expectedOrigin]
|
|
| expectedOrigin == "*" ->
|
|
return ()
|
|
| expectedOrigin == actualOrigin ->
|
|
return ()
|
|
_ | actualOrigin == childOrigin ->
|
|
return ()
|
|
| otherwise ->
|
|
Control.Exception.throwIO (NotCORSCompliant {..})
|
|
corsCompliant _ _ _ = return ()
|
|
|
|
renderComponent :: Text -> Text
|
|
renderComponent component = "/" <> URI.Encode.encodeText component
|
|
|
|
renderQuery :: Text -> Text
|
|
renderQuery query = "?" <> query
|
|
|
|
renderURL :: URL -> Text
|
|
renderURL url =
|
|
schemeText
|
|
<> authority
|
|
<> pathText
|
|
<> queryText
|
|
where
|
|
URL {..} = url
|
|
|
|
File {..} = path
|
|
|
|
Directory {..} = directory
|
|
|
|
schemeText = case scheme of
|
|
HTTP -> "http://"
|
|
HTTPS -> "https://"
|
|
|
|
pathText =
|
|
foldMap renderComponent (reverse components)
|
|
<> renderComponent file
|
|
|
|
queryText = foldMap renderQuery query
|
|
|
|
type HTTPHeader = Network.HTTP.Types.Header
|
|
|
|
fetchFromHttpUrl
|
|
:: Manager
|
|
-> URL
|
|
-> Maybe [HTTPHeader]
|
|
-> StateT Status IO Text.Text
|
|
#ifdef __GHCJS__
|
|
fetchFromHttpUrl _ childURL Nothing = do
|
|
let childURLText = renderURL childURL
|
|
|
|
let childURLString = Text.unpack childURLText
|
|
|
|
-- No need to add a CORS compliance check when using GHCJS. The browser
|
|
-- will already check the CORS compliance of the following XHR
|
|
(statusCode, body) <- liftIO (JavaScript.XHR.get childURLText)
|
|
|
|
case statusCode of
|
|
200 -> return ()
|
|
_ -> fail (childURLString <> " returned a non-200 status code: " <> show statusCode)
|
|
|
|
return body
|
|
fetchFromHttpUrl _ _ _ = do
|
|
fail "Dhall does not yet support custom headers when built using GHCJS"
|
|
#else
|
|
fetchFromHttpUrl manager childURL mheaders = do
|
|
let childURLString = Text.unpack (renderURL childURL)
|
|
|
|
request <- liftIO (HTTP.parseUrlThrow childURLString)
|
|
|
|
let requestWithHeaders =
|
|
case mheaders of
|
|
Nothing -> request
|
|
Just headers -> request { HTTP.requestHeaders = headers }
|
|
|
|
let io = HTTP.httpLbs requestWithHeaders manager
|
|
|
|
let handler e = do
|
|
let _ = e :: HttpException
|
|
Control.Exception.throwIO (mkPrettyHttpException e)
|
|
|
|
response <- liftIO (Control.Exception.handle handler io)
|
|
|
|
Status {..} <- State.get
|
|
|
|
let Chained parentImport = NonEmpty.head _stack
|
|
|
|
let parentImportType = importType (importHashed parentImport)
|
|
|
|
corsCompliant parentImportType childURL (HTTP.responseHeaders response)
|
|
|
|
let bytes = HTTP.responseBody response
|
|
|
|
case Data.Text.Lazy.Encoding.decodeUtf8' bytes of
|
|
Left err -> liftIO (Control.Exception.throwIO err)
|
|
Right text -> return (Data.Text.Lazy.toStrict text)
|
|
#endif
|