diff --git a/dhall/dhall-lang b/dhall/dhall-lang index 8fd8d22..7d521e2 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit 8fd8d22a2e1dee9119695814fb1a418b5470a329 +Subproject commit 7d521e2f56ccc3d8fcdb84fd25857a26acd49b80 diff --git a/dhall/src/Dhall/Core.hs b/dhall/src/Dhall/Core.hs index c716da2..162e76b 100644 --- a/dhall/src/Dhall/Core.hs +++ b/dhall/src/Dhall/Core.hs @@ -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 diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index c00873c..0a0f675 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -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 diff --git a/dhall/src/Dhall/Import/HTTP.hs b/dhall/src/Dhall/Import/HTTP.hs index 1ac4f5b..ba3d219 100644 --- a/dhall/src/Dhall/Import/HTTP.hs +++ b/dhall/src/Dhall/Import/HTTP.hs @@ -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 diff --git a/dhall/src/Dhall/Util.hs b/dhall/src/Dhall/Util.hs index 9a0bcac..9f73e4e 100644 --- a/dhall/src/Dhall/Util.hs +++ b/dhall/src/Dhall/Util.hs @@ -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"