{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Import.HTTP
( fetchFromHttpUrl
) 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 Dhall.Core
( Import(..)
, ImportHashed(..)
, ImportType(..)
, Scheme(..)
, URL(..)
)
import Dhall.URL (renderURL)
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 Dhall.Import.Types
import qualified Control.Exception
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Encoding
#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 :: String -> HttpException -> PrettyHttpException
mkPrettyHttpException :: String -> HttpException -> PrettyHttpException
mkPrettyHttpException url :: String
url ex :: HttpException
ex =
String -> Dynamic -> PrettyHttpException
PrettyHttpException (String -> HttpException -> String
renderPrettyHttpException String
url HttpException
ex) (HttpException -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn HttpException
ex)
renderPrettyHttpException :: String -> HttpException -> String
#if MIN_VERSION_http_client(0,5,0)
renderPrettyHttpException :: String -> HttpException -> String
renderPrettyHttpException _ (InvalidUrlException _ r :: String
r) =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Invalid URL\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "URL: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
renderPrettyHttpException url :: String
url (HttpExceptionRequest _ e :: HttpExceptionContent
e) =
case HttpExceptionContent
e of
ConnectionFailure _ ->
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Remote host not found\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "URL: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
url String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
InvalidDestinationHost host :: ByteString
host ->
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Invalid remote host name:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "Host: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
ResponseTimeout ->
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: The remote host took too long to respond\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "URL: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
url String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
StatusCodeException response :: Response ()
response body :: ByteString
body -> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix
where
prefix :: String
prefix
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 401 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Access unauthorized\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 403 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Access forbidden\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 404 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Remote file not found\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 500 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Server-side failure\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 502 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Upstream failure\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 503 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Server temporarily unavailable\n"
| Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 504 =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: Upstream timeout\n"
| Bool
otherwise =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\ESC[1;31mError\ESC[0m: HTTP request failure\n"
suffix :: String
suffix =
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "HTTP status code: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
statusCode String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "URL: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
url String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
message
statusCode :: Int
statusCode =
Status -> Int
Network.HTTP.Types.statusCode
(Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ()
response)
message :: String
message =
case ByteString -> Either UnicodeException Text
Data.Text.Encoding.decodeUtf8' ByteString
body of
Left _ ->
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "Message (non-UTF8 bytes):\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
truncatedBodyString String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
where
bodyString :: String
bodyString = ByteString -> String
forall a. Show a => a -> String
show ByteString
body
dots :: String
dots = "…"
truncatedLength :: Int
truncatedLength = 80 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
dots
truncatedBodyString :: String
truncatedBodyString
| Int
truncatedLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
bodyString =
Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
truncatedLength String
bodyString String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dots
| Bool
otherwise =
String
bodyString
Right "" ->
""
Right bodyText :: Text
bodyText ->
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "Message:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
prefixedText
where
prefixedLines :: [Text]
prefixedLines =
(Text -> Text -> Text) -> [Text] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a -> a
combine [Text]
prefixes (Text -> [Text]
Text.lines Text
bodyText)
where
prefixes :: [Text]
prefixes =
(Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(1 ::Int)..7] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ "…" ]
combine :: a -> a -> a
combine n :: a
n line :: a
line = a
n a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "│ " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
line
prefixedText :: Text
prefixedText = [Text] -> Text
Text.unlines [Text]
prefixedLines
e' :: HttpExceptionContent
e' -> "\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
e' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
#else
renderPrettyHttpException url e = case e of
FailedConnectionException2 _ _ _ e' ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Wrong host:\n"
<> "\n"
<> "Host: " <> show e' <> "\n"
InvalidDestinationHost host ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Invalid host name:\n"
<> "\n"
<> "Host: " <> show host <> "\n"
ResponseTimeout ->
"\ESC[1;31mError\ESC[0m: The host took too long to respond\n"
<> "\n"
<> "URL: " <> url <> "\n"
e' -> "\n"
<> show e' <> "\n"
#endif
newManager :: StateT Status IO Manager
newManager :: StateT Status IO Manager
newManager = do
let settings :: ManagerSettings
settings = ManagerSettings
HTTP.tlsManagerSettings
#if MIN_VERSION_http_client(0,5,0)
{ managerResponseTimeout :: ResponseTimeout
HTTP.managerResponseTimeout = Int -> ResponseTimeout
HTTP.responseTimeoutMicro (30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000) }
#else
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) }
#endif
Status { _manager :: Status -> Maybe Manager
_manager = Maybe Manager
oldManager, ..} <- StateT Status IO Status
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
case Maybe Manager
oldManager of
Nothing -> do
Manager
manager <- IO Manager -> StateT Status IO Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
settings)
Status -> StateT Status IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (Status :: NonEmpty Chained
-> [Depends]
-> Map Chained ImportSemantics
-> Maybe Manager
-> (URL -> StateT Status IO Text)
-> Substitutions Src Void
-> Maybe (ReifiedNormalizer Void)
-> Context (Expr Src Void)
-> SemanticCacheMode
-> Status
Status { _manager :: Maybe Manager
_manager = Manager -> Maybe Manager
forall a. a -> Maybe a
Just Manager
manager , ..})
Manager -> StateT Status IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
manager
Just manager :: Manager
manager -> do
Manager -> StateT Status IO Manager
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
manager
data NotCORSCompliant = NotCORSCompliant
{ NotCORSCompliant -> [ByteString]
expectedOrigins :: [ByteString]
, NotCORSCompliant -> ByteString
actualOrigin :: ByteString
}
instance Exception NotCORSCompliant
instance Show NotCORSCompliant where
show :: NotCORSCompliant -> String
show (NotCORSCompliant {..}) =
String
forall string. IsString string => string
Dhall.Util._ERROR String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ": Not CORS compliant\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "Dhall supports transitive imports, meaning that an imported expression can\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "import other expressions. However, a remote import (the \"parent\" import)\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "cannot import another remote import (the \"child\" import) unless the child\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "import grants permission to do using CORS. The child import must respond with\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "an `Access-Control-Allow-Origin` response header that matches the parent\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "import, otherwise Dhall rejects the import.\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
prologue
where
prologue :: String
prologue =
case [ByteString]
expectedOrigins of
[ expectedOrigin :: ByteString
expectedOrigin ] ->
"The following parent import:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "↳ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
actualOrigin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "... did not match the expected origin:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "↳ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
expectedOrigin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "... so import resolution failed.\n"
[] ->
"The child response did not include any `Access-Control-Allow-Origin` header,\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "so import resolution failed.\n"
_:_:_ ->
"The child response included more than one `Access-Control-Allow-Origin` header,\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "when only one such header should have been present, so import resolution\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "failed.\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "This may indicate that the server for the child import is misconfigured.\n"
corsCompliant
:: MonadIO io
=> ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant :: ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant (Remote parentURL :: URL
parentURL) childURL :: URL
childURL responseHeaders :: [(CI ByteString, ByteString)]
responseHeaders = IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ do
let toOrigin :: URL -> ByteString
toOrigin (URL {..}) =
Text -> ByteString
Data.Text.Encoding.encodeUtf8 (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
authority)
where
prefix :: Text
prefix =
case Scheme
scheme of
HTTP -> "http"
HTTPS -> "https"
let actualOrigin :: ByteString
actualOrigin = URL -> ByteString
toOrigin URL
parentURL
let childOrigin :: ByteString
childOrigin = URL -> ByteString
toOrigin URL
childURL
let predicate :: (a, b) -> Bool
predicate (header :: a
header, _) = a
header a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== "Access-Control-Allow-Origin"
let originHeaders :: [(CI ByteString, ByteString)]
originHeaders = ((CI ByteString, ByteString) -> Bool)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CI ByteString, ByteString) -> Bool
forall a b. (Eq a, IsString a) => (a, b) -> Bool
predicate [(CI ByteString, ByteString)]
responseHeaders
let expectedOrigins :: [ByteString]
expectedOrigins = ((CI ByteString, ByteString) -> ByteString)
-> [(CI ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd [(CI ByteString, ByteString)]
originHeaders
case [ByteString]
expectedOrigins of
[expectedOrigin :: ByteString
expectedOrigin]
| ByteString
expectedOrigin ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "*" ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ByteString
expectedOrigin ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualOrigin ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ | ByteString
actualOrigin ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
childOrigin ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise ->
NotCORSCompliant -> IO ()
forall e a. Exception e => e -> IO a
Control.Exception.throwIO (NotCORSCompliant :: [ByteString] -> ByteString -> NotCORSCompliant
NotCORSCompliant {..})
corsCompliant _ _ _ = () -> io ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type = Network.HTTP.Types.Header
fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text
fetchFromHttpUrl :: URL -> Maybe [(CI ByteString, ByteString)] -> StateT Status IO Text
fetchFromHttpUrl childURL :: URL
childURL mheaders :: Maybe [(CI ByteString, ByteString)]
mheaders = do
Manager
manager <- StateT Status IO Manager
newManager
let childURLString :: String
childURLString = Text -> String
Text.unpack (URL -> Text
renderURL URL
childURL)
Request
request <- IO Request -> StateT Status IO Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow String
childURLString)
let requestWithHeaders :: Request
requestWithHeaders =
case Maybe [(CI ByteString, ByteString)]
mheaders of
Nothing -> Request
request
Just headers :: [(CI ByteString, ByteString)]
headers -> Request
request { requestHeaders :: [(CI ByteString, ByteString)]
HTTP.requestHeaders = [(CI ByteString, ByteString)]
headers }
let io :: IO (Response ByteString)
io = Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
requestWithHeaders Manager
manager
let handler :: HttpException -> IO a
handler e :: HttpException
e = do
let HttpException
_ = HttpException
e :: HttpException
PrettyHttpException -> IO a
forall e a. Exception e => e -> IO a
Control.Exception.throwIO (String -> HttpException -> PrettyHttpException
mkPrettyHttpException String
childURLString HttpException
e)
Response ByteString
response <- IO (Response ByteString) -> StateT Status IO (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((HttpException -> IO (Response ByteString))
-> IO (Response ByteString) -> IO (Response ByteString)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.handle HttpException -> IO (Response ByteString)
forall a. HttpException -> IO a
handler IO (Response ByteString)
io)
Status {..} <- StateT Status IO Status
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let Chained parentImport :: Import
parentImport = NonEmpty Chained -> Chained
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Chained
_stack
let parentImportType :: ImportType
parentImportType = ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
parentImport)
ImportType
-> URL -> [(CI ByteString, ByteString)] -> StateT Status IO ()
forall (io :: * -> *).
MonadIO io =>
ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant ImportType
parentImportType URL
childURL (Response ByteString -> [(CI ByteString, ByteString)]
forall body. Response body -> [(CI ByteString, ByteString)]
HTTP.responseHeaders Response ByteString
response)
let bytes :: ByteString
bytes = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response
case ByteString -> Either UnicodeException Text
Data.Text.Lazy.Encoding.decodeUtf8' ByteString
bytes of
Left err :: UnicodeException
err -> IO Text -> StateT Status IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UnicodeException -> IO Text
forall e a. Exception e => e -> IO a
Control.Exception.throwIO UnicodeException
err)
Right text :: Text
text -> Text -> StateT Status IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
Data.Text.Lazy.toStrict Text
text)