{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Import (
exprFromImport
, load
, loadWith
, loadWithContext
, hashExpression
, hashExpressionToCode
, Status(..)
, emptyStatus
, Cycle(..)
, ReferentiallyOpaque(..)
, Imported(..)
, PrettyHttpException(..)
, MissingFile(..)
, MissingEnvironmentVariable(..)
) where
import Control.Applicative (empty)
import Control.Exception (Exception, SomeException, throwIO)
import Control.Monad (join)
import Control.Monad.Catch (throwM, MonadCatch(catch))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State.Strict (StateT)
import Crypto.Hash (SHA256)
import Data.CaseInsensitive (CI)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Semigroup (sconcat, (<>))
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
#if MIN_VERSION_base(4,8,0)
#else
import Data.Traversable (traverse)
#endif
import Data.Typeable (Typeable)
import Formatting.Buildable (build)
import System.FilePath ((</>))
import Dhall.Core
( Expr(..)
, Chunks(..)
, Directory(..)
, File(..)
, FilePrefix(..)
, ImportHashed(..)
, ImportType(..)
, ImportMode(..)
, Import(..)
)
import Dhall.Parser (Parser(..), ParseError(..), Src(..))
import Dhall.TypeCheck (X(..))
import Lens.Family (LensLike')
import Lens.Family.State.Strict (zoom)
#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 Control.Monad.Trans.State.Strict as State
import qualified Crypto.Hash
import qualified Data.ByteString
import qualified Data.CaseInsensitive
import qualified Data.Foldable
import qualified Data.List as List
import qualified Data.HashMap.Strict.InsOrd
import qualified Data.Map.Strict as Map
import qualified Data.Text.Encoding
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy.Encoding
import qualified Data.Text.Lazy.IO
import qualified Dhall.Core
import qualified Dhall.Parser
import qualified Dhall.Context
import qualified Dhall.TypeCheck
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified System.Environment
import qualified System.Directory
import qualified System.FilePath as FilePath
import qualified Text.Megaparsec
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token
builderToString :: Builder -> String
builderToString = Text.unpack . Builder.toLazyText
newtype Cycle = Cycle
{ cyclicImport :: Import
}
deriving (Typeable)
instance Exception Cycle
instance Show Cycle where
show (Cycle import_) =
"\nCyclic import: " ++ builderToString (build import_)
newtype ReferentiallyOpaque = ReferentiallyOpaque
{ opaqueImport :: Import
} deriving (Typeable)
instance Exception ReferentiallyOpaque
instance Show ReferentiallyOpaque where
show (ReferentiallyOpaque import_) =
"\nReferentially opaque import: " ++ builderToString (build import_)
data Imported e = Imported
{ importStack :: [Import]
, nested :: e
} deriving (Typeable)
instance Exception e => Exception (Imported e)
instance Show e => Show (Imported e) where
show (Imported imports e) =
(case imports of [] -> ""; _ -> "\n")
++ unlines (map indent imports')
++ show e
where
indent (n, import_) =
take (2 * n) (repeat ' ') ++ "↳ " ++ builderToString (build import_)
imports' = zip [0..] (drop 1 (reverse (canonicalizeAll imports)))
newtype PrettyHttpException = PrettyHttpException HttpException
deriving (Typeable)
instance Exception PrettyHttpException
#if MIN_VERSION_http_client(0,5,0)
instance Show PrettyHttpException where
show (PrettyHttpException (InvalidUrlException _ r)) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Invalid URL\n"
<> "\n"
<> "↳ " <> show r
show (PrettyHttpException (HttpExceptionRequest _ e)) = case e of
ConnectionFailure 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'
#else
instance Show PrettyHttpException where
show (PrettyHttpException 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
data MissingFile = MissingFile FilePath
deriving (Typeable)
instance Exception MissingFile
instance Show MissingFile where
show (MissingFile path) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Missing file "
<> path
<> "\n"
newtype MissingEnvironmentVariable = MissingEnvironmentVariable { name :: Text }
deriving (Typeable)
instance Exception MissingEnvironmentVariable
instance Show MissingEnvironmentVariable where
show (MissingEnvironmentVariable {..}) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Missing environment variable\n"
<> "\n"
<> "↳ " <> Text.unpack name
data Status = Status
{ _stack :: [Import]
, _cache :: Map Import (Expr Src X)
, _manager :: Maybe Manager
}
emptyStatus :: Status
emptyStatus = Status [] Map.empty Nothing
canonicalizeAll :: [Import] -> [Import]
canonicalizeAll = map canonicalizeImport . List.tails
stack :: Functor f => LensLike' f Status [Import]
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
cache :: Functor f => LensLike' f Status (Map Import (Expr Src X))
cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))
manager :: Functor f => LensLike' f Status (Maybe Manager)
manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))
needManager :: StateT Status IO Manager
needManager = do
x <- zoom manager State.get
case x of
Just m -> return m
Nothing -> do
let settings = HTTP.tlsManagerSettings
#if MIN_VERSION_http_client(0,5,0)
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) }
#else
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) }
#endif
m <- liftIO (HTTP.newManager settings)
zoom manager (State.put (Just m))
return m
class Canonicalize path where
canonicalize :: path -> path
instance Canonicalize Directory where
canonicalize (Directory []) = Directory []
canonicalize (Directory ("." : components₀)) =
canonicalize (Directory components₀)
canonicalize (Directory (".." : components₀)) =
case canonicalize (Directory components₀) of
Directory [] -> Directory [ ".." ]
Directory (_ : components₁) -> Directory components₁
canonicalize (Directory (component : components₀)) =
Directory (component : components₁)
where
Directory components₁ = canonicalize (Directory components₀)
instance Canonicalize File where
canonicalize (File { directory, .. }) =
File { directory = canonicalize directory, .. }
instance Canonicalize ImportType where
canonicalize (Local prefix file) =
Local prefix (canonicalize file)
canonicalize (URL prefix file suffix header) =
URL prefix (canonicalize file) suffix header
canonicalize (Env name) =
Env name
instance Canonicalize ImportHashed where
canonicalize (ImportHashed hash importType) =
ImportHashed hash (canonicalize importType)
instance Canonicalize Import where
canonicalize (Import importHashed importMode) =
Import (canonicalize importHashed) importMode
canonicalizeImport :: [Import] -> Import
canonicalizeImport imports =
canonicalize (sconcat (defaultImport :| reverse imports))
where
defaultImport =
Import
{ importMode = Code
, importHashed = ImportHashed
{ hash = Nothing
, importType = Local Here (File (Directory []) ".")
}
}
toHeaders
:: Expr s a
-> Maybe [(CI Data.ByteString.ByteString, Data.ByteString.ByteString)]
toHeaders (ListLit _ hs) = do
hs' <- mapM toHeader hs
return (Data.Foldable.toList hs')
toHeaders _ = do
empty
toHeader
:: Expr s a
-> Maybe (CI Data.ByteString.ByteString, Data.ByteString.ByteString)
toHeader (RecordLit m) = do
TextLit (Chunks [] keyBuilder ) <- Data.HashMap.Strict.InsOrd.lookup "header" m
TextLit (Chunks [] valueBuilder) <- Data.HashMap.Strict.InsOrd.lookup "value" m
let keyText = Text.toStrict (Builder.toLazyText keyBuilder )
let valueText = Text.toStrict (Builder.toLazyText valueBuilder)
let keyBytes = Data.Text.Encoding.encodeUtf8 keyText
let valueBytes = Data.Text.Encoding.encodeUtf8 valueText
return (Data.CaseInsensitive.mk keyBytes, valueBytes)
toHeader _ = do
empty
data InternalError = InternalError deriving (Typeable)
_ERROR :: String
_ERROR = "\ESC[1;31mError\ESC[0m"
instance Show InternalError where
show InternalError = unlines
[ _ERROR <> ": Compiler bug "
, " "
, "Explanation: This error message means that there is a bug in the Dhall compiler."
, "You didn't do anything wrong, but if you would like to see this problem fixed "
, "then you should report the bug at: "
, " "
, "https://github.com/dhall-lang/dhall-haskell/issues "
, " "
, "Please include the following text in your bug report: "
, " "
, "``` "
, "Header extraction failed even though the header type-checked "
, "``` "
]
instance Exception InternalError
data HashMismatch = HashMismatch
{ expectedHash :: Crypto.Hash.Digest SHA256
, actualHash :: Crypto.Hash.Digest SHA256
} deriving (Typeable)
instance Exception HashMismatch
instance Show HashMismatch where
show (HashMismatch {..}) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Import integrity check failed\n"
<> "\n"
<> "Expected hash:\n"
<> "\n"
<> "↳ " <> show expectedHash <> "\n"
<> "\n"
<> "Actual hash:\n"
<> "\n"
<> "↳ " <> show actualHash <> "\n"
exprFromImport :: Import -> StateT Status IO (Expr Src Import)
exprFromImport (Import {..}) = do
let ImportHashed {..} = importHashed
(path, text) <- case importType of
Local prefix (File {..}) -> liftIO $ do
let Directory {..} = directory
prefixPath <- case prefix of
Home -> do
System.Directory.getHomeDirectory
Absolute -> do
return "/"
Parent -> do
pwd <- System.Directory.getCurrentDirectory
return (FilePath.takeDirectory pwd)
Here -> do
System.Directory.getCurrentDirectory
let cs = map Text.unpack (file : components)
let cons component dir = dir </> component
let path = foldr cons prefixPath cs
exists <- System.Directory.doesFileExist path
if exists
then return ()
else throwIO (MissingFile path)
text <- Data.Text.Lazy.IO.readFile path
return (path, text)
URL prefix file suffix maybeHeaders -> do
m <- needManager
let fileText = Builder.toLazyText (build file)
let url = Text.unpack (prefix <> fileText <> suffix)
request <- liftIO (HTTP.parseUrlThrow url)
requestWithHeaders <- case maybeHeaders of
Nothing -> return request
Just importHashed_ -> do
expr <- loadStaticIO Dhall.Context.empty
(const Nothing)
(Import importHashed_ Code)
let expected :: Expr Src X
expected =
App List
( Record
( Data.HashMap.Strict.InsOrd.fromList
[("header", Text), ("value", Text)]
)
)
let suffix_ =
( Builder.toLazyText
. build
) expected
let annot = case expr of
Note (Src begin end bytes) _ ->
Note (Src begin end bytes') (Annot expr expected)
where
bytes' = bytes <> " : " <> suffix_
_ ->
Annot expr expected
case Dhall.TypeCheck.typeOf annot of
Left err -> liftIO (throwIO err)
Right _ -> return ()
let expr' = Dhall.Core.normalize expr
headers <- case toHeaders expr' of
Just headers -> do
return headers
Nothing -> do
liftIO (throwIO InternalError)
let requestWithHeaders = request
{ HTTP.requestHeaders = headers
}
return requestWithHeaders
response <- liftIO (HTTP.httpLbs requestWithHeaders m)
let bytes = HTTP.responseBody response
case Data.Text.Lazy.Encoding.decodeUtf8' bytes of
Left err -> liftIO (throwIO err)
Right text -> return (url, text)
Env env -> liftIO $ do
x <- System.Environment.lookupEnv (Text.unpack env)
case x of
Just string -> return (Text.unpack env, Text.pack string)
Nothing -> throwIO (MissingEnvironmentVariable env)
case importMode of
Code -> do
let parser = unParser $ do
Text.Parser.Token.whiteSpace
r <- Dhall.Parser.expr
Text.Parser.Combinators.eof
return r
case Text.Megaparsec.parse parser path text of
Left errInfo -> do
liftIO (throwIO (ParseError errInfo text))
Right expr -> do
return expr
RawText -> do
return (TextLit (Chunks [] (build text)))
loadDynamic
:: forall m . MonadCatch m
=> (Import -> StateT Status m (Expr Src Import))
-> Import
-> StateT Status m (Expr Src Import)
loadDynamic from_import import_ = do
imports <- zoom stack State.get
let handler :: SomeException -> StateT Status m (Expr Src Import)
handler e = throwM (Imported (import_:imports) e)
from_import (canonicalizeImport (import_:imports)) `catch` handler
loadStaticIO
:: Dhall.Context.Context (Expr Src X)
-> Dhall.Core.Normalizer X
-> Import
-> StateT Status IO (Expr Src X)
loadStaticIO = loadStaticWith exprFromImport
loadWith
:: MonadCatch m
=> (Import -> StateT Status m (Expr Src Import))
-> Dhall.Context.Context (Expr Src X)
-> Dhall.Core.Normalizer X
-> Expr Src Import
-> m (Expr Src X)
loadWith from_import ctx n = evalStatus (loadStaticWith from_import ctx n)
loadWithContext
:: Dhall.Context.Context (Expr Src X)
-> Dhall.Core.Normalizer X
-> Expr Src Import
-> IO (Expr Src X)
loadWithContext ctx n = evalStatus (loadStaticIO ctx n)
loadStaticWith
:: MonadCatch m
=> (Import -> StateT Status m (Expr Src Import))
-> Dhall.Context.Context (Expr Src X)
-> Dhall.Core.Normalizer X
-> Import
-> StateT Status m (Expr Src X)
loadStaticWith from_import ctx n import_ = do
imports <- zoom stack State.get
let local (Import (ImportHashed _ (URL {})) _) = False
local (Import (ImportHashed _ (Local {})) _) = True
local (Import (ImportHashed _ (Env {})) _) = True
let parent = canonicalizeImport imports
let here = canonicalizeImport (import_:imports)
if local here && not (local parent)
then throwM (Imported imports (ReferentiallyOpaque import_))
else return ()
expr <- if here `elem` canonicalizeAll imports
then throwM (Imported imports (Cycle import_))
else do
m <- zoom cache State.get
case Map.lookup here m of
Just expr -> return expr
Nothing -> do
expr' <- loadDynamic from_import import_
expr'' <- case traverse (\_ -> Nothing) expr' of
Just expr -> return expr
Nothing -> do
let imports' = import_:imports
zoom stack (State.put imports')
expr'' <- fmap join (traverse (loadStaticWith from_import ctx n)
expr')
zoom stack (State.put imports)
return expr''
expr''' <- case Dhall.TypeCheck.typeWith ctx expr'' of
Left err -> throwM (Imported (import_:imports) err)
Right _ -> return (Dhall.Core.normalizeWith n expr'')
zoom cache (State.put $! Map.insert here expr''' m)
return expr'''
case hash (importHashed import_) of
Nothing -> do
return ()
Just expectedHash -> do
let actualHash = hashExpression expr
if expectedHash == actualHash
then return ()
else throwM (Imported (import_:imports) (HashMismatch {..}))
return expr
evalStatus
:: (Traversable f, Monad m, Monad f)
=> (a -> StateT Status m (f b)) -> f a -> m (f b)
evalStatus cb expr = State.evalStateT (fmap join (traverse cb expr)) emptyStatus
load :: Expr Src Import -> IO (Expr Src X)
load = loadWithContext Dhall.Context.empty (const Nothing)
hashExpression :: Expr s X -> (Crypto.Hash.Digest SHA256)
hashExpression expr = Crypto.Hash.hashlazy actualBytes
where
text = Dhall.Core.pretty (Dhall.Core.normalize expr)
actualBytes = Data.Text.Lazy.Encoding.encodeUtf8 text
hashExpressionToCode :: Expr s X -> Text
hashExpressionToCode expr = "sha256:" <> Text.pack (show (hashExpression expr))