Add CORS support (#846)
... as standardized in https://github.com/dhall-lang/dhall-lang/pull/411
This commit is contained in:
Gabriel Gonzalez
GitHub
parent
b31ec4db5c
commit
4b7bdd458c
|
|
@ -1 +1 @@
|
|||
Subproject commit 8fd8d22a2e1dee9119695814fb1a418b5470a329
|
||||
Subproject commit 7d521e2f56ccc3d8fcdb84fd25857a26acd49b80
|
||||
|
|
@ -182,6 +182,30 @@ data URL = URL
|
|||
, headers :: Maybe ImportHashed
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
instance Pretty URL where
|
||||
pretty (URL {..}) =
|
||||
schemeDoc
|
||||
<> "://"
|
||||
<> Pretty.pretty authority
|
||||
<> Pretty.pretty path
|
||||
<> queryDoc
|
||||
<> fragmentDoc
|
||||
<> foldMap prettyHeaders headers
|
||||
where
|
||||
prettyHeaders h = " using " <> Pretty.pretty h
|
||||
|
||||
schemeDoc = case scheme of
|
||||
HTTP -> "http"
|
||||
HTTPS -> "https"
|
||||
|
||||
queryDoc = case query of
|
||||
Nothing -> ""
|
||||
Just q -> "?" <> Pretty.pretty q
|
||||
|
||||
fragmentDoc = case fragment of
|
||||
Nothing -> ""
|
||||
Just f -> "#" <> Pretty.pretty f
|
||||
|
||||
-- | The type of import (i.e. local vs. remote vs. environment)
|
||||
data ImportType
|
||||
= Local FilePrefix File
|
||||
|
|
@ -222,28 +246,7 @@ instance Pretty ImportType where
|
|||
pretty (Local prefix file) =
|
||||
Pretty.pretty prefix <> Pretty.pretty file
|
||||
|
||||
pretty (Remote (URL {..})) =
|
||||
schemeDoc
|
||||
<> "://"
|
||||
<> Pretty.pretty authority
|
||||
<> Pretty.pretty path
|
||||
<> queryDoc
|
||||
<> fragmentDoc
|
||||
<> foldMap prettyHeaders headers
|
||||
where
|
||||
prettyHeaders h = " using " <> Pretty.pretty h
|
||||
|
||||
schemeDoc = case scheme of
|
||||
HTTP -> "http"
|
||||
HTTPS -> "https"
|
||||
|
||||
queryDoc = case query of
|
||||
Nothing -> ""
|
||||
Just q -> "?" <> Pretty.pretty q
|
||||
|
||||
fragmentDoc = case fragment of
|
||||
Nothing -> ""
|
||||
Just f -> "#" <> Pretty.pretty f
|
||||
pretty (Remote url) = Pretty.pretty url
|
||||
|
||||
pretty (Env env) = "env:" <> Pretty.pretty env
|
||||
|
||||
|
|
|
|||
|
|
@ -158,7 +158,6 @@ import Dhall.Core
|
|||
, ImportMode(..)
|
||||
, Import(..)
|
||||
, ReifiedNormalizer(..)
|
||||
, Scheme(..)
|
||||
, URL(..)
|
||||
)
|
||||
#ifdef MIN_VERSION_http_client
|
||||
|
|
@ -190,7 +189,6 @@ import qualified Dhall.Map
|
|||
import qualified Dhall.Parser
|
||||
import qualified Dhall.Pretty.Internal
|
||||
import qualified Dhall.TypeCheck
|
||||
import qualified Network.URI.Encode
|
||||
import qualified System.Environment
|
||||
import qualified System.Directory as Directory
|
||||
import qualified System.FilePath as FilePath
|
||||
|
|
@ -612,28 +610,7 @@ exprFromUncachedImport (Import {..}) = do
|
|||
|
||||
return (path, text)
|
||||
|
||||
Remote (URL scheme authority path query fragment maybeHeaders) -> do
|
||||
let prefix =
|
||||
(case scheme of HTTP -> "http"; HTTPS -> "https")
|
||||
<> "://"
|
||||
<> authority
|
||||
|
||||
let File {..} = path
|
||||
let Directory {..} = directory
|
||||
|
||||
let pathComponentToText component =
|
||||
"/" <> Network.URI.Encode.encodeText component
|
||||
|
||||
let fileText =
|
||||
Text.concat
|
||||
(map pathComponentToText (reverse components))
|
||||
<> pathComponentToText file
|
||||
|
||||
let suffix =
|
||||
(case query of Nothing -> ""; Just q -> "?" <> q)
|
||||
<> (case fragment of Nothing -> ""; Just f -> "#" <> f)
|
||||
let url = Text.unpack (prefix <> fileText <> suffix)
|
||||
|
||||
Remote url@URL { headers = maybeHeaders } -> do
|
||||
mheaders <- case maybeHeaders of
|
||||
Nothing -> return Nothing
|
||||
Just importHashed_ -> do
|
||||
|
|
@ -671,7 +648,9 @@ exprFromUncachedImport (Import {..}) = do
|
|||
#ifdef MIN_VERSION_http_client
|
||||
fetchFromHttpUrl url mheaders
|
||||
#else
|
||||
liftIO (throwIO (CannotImportHTTPURL url mheaders))
|
||||
let urlString = Text.unpack (Dhall.Core.pretty url)
|
||||
|
||||
liftIO (throwIO (CannotImportHTTPURL urlString mheaders))
|
||||
#endif
|
||||
|
||||
Env env -> liftIO $ do
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
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)
|
||||
|
|
@ -13,15 +14,27 @@ import Data.Dynamic (fromDynamic, toDyn)
|
|||
import Data.Semigroup ((<>))
|
||||
import Lens.Family.State.Strict (zoom)
|
||||
|
||||
import qualified Control.Monad.Trans.State.Strict as State
|
||||
import qualified Data.Text as Text
|
||||
import Dhall.Core
|
||||
( 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.Core
|
||||
import qualified Dhall.Util
|
||||
|
||||
import Dhall.Import.Types
|
||||
|
||||
import qualified Control.Exception
|
||||
#ifdef __GHCJS__
|
||||
import qualified JavaScript.XHR
|
||||
#else
|
||||
import qualified Control.Exception
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Encoding
|
||||
#endif
|
||||
|
|
@ -112,26 +125,109 @@ needManager = do
|
|||
zoom manager (State.put (Just (toDyn m)))
|
||||
return m
|
||||
|
||||
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 ()
|
||||
|
||||
fetchFromHttpUrl
|
||||
:: String
|
||||
:: URL
|
||||
-> Maybe [(CI ByteString, ByteString)]
|
||||
-> StateT (Status m) IO (String, Text.Text)
|
||||
#ifdef __GHCJS__
|
||||
fetchFromHttpUrl url Nothing = do
|
||||
(statusCode, body) <- liftIO (JavaScript.XHR.get (Text.pack url))
|
||||
fetchFromHttpUrl childURL Nothing = do
|
||||
let childURLText = Dhall.Core.pretty 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 (url <> " returned a non-200 status code: " <> show statusCode)
|
||||
_ -> fail (childURLString <> " returned a non-200 status code: " <> show statusCode)
|
||||
|
||||
return (url, body)
|
||||
return (childURLString, body)
|
||||
fetchFromHttpUrl _ _ = do
|
||||
fail "Dhall does not yet support custom headers when built using GHCJS"
|
||||
#else
|
||||
fetchFromHttpUrl url mheaders = do
|
||||
fetchFromHttpUrl childURL mheaders = do
|
||||
let childURLString = Text.unpack (Dhall.Core.pretty childURL)
|
||||
|
||||
m <- needManager
|
||||
|
||||
request <- liftIO (HTTP.parseUrlThrow url)
|
||||
request <- liftIO (HTTP.parseUrlThrow childURLString)
|
||||
|
||||
let requestWithHeaders =
|
||||
case mheaders of
|
||||
|
|
@ -146,9 +242,17 @@ fetchFromHttpUrl url mheaders = do
|
|||
|
||||
response <- liftIO (Control.Exception.handle handler io)
|
||||
|
||||
Status {..} <- State.get
|
||||
|
||||
let 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 (url, Data.Text.Lazy.toStrict text)
|
||||
Right text -> return (childURLString, Data.Text.Lazy.toStrict text)
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -6,9 +6,11 @@ module Dhall.Util
|
|||
( snip
|
||||
, snipDoc
|
||||
, insert
|
||||
, _ERROR
|
||||
) where
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Prettyprint.Doc (Doc, Pretty)
|
||||
import Dhall.Pretty (Ann)
|
||||
|
|
@ -73,3 +75,7 @@ takeEnd n l = go (drop n l) l
|
|||
insert :: Pretty a => a -> Doc Ann
|
||||
insert expression =
|
||||
"↳ " <> Pretty.align (snipDoc (Pretty.pretty expression))
|
||||
|
||||
-- | Prefix used for error messages
|
||||
_ERROR :: IsString string => string
|
||||
_ERROR = "\ESC[1;31mError\ESC[0m"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user