Fix chaining for imports protected by integrity checks (#584)
Fixes #582 This introduces a new `exprToImport` utility that is used to cache the fully-resolved import
This commit is contained in:
Gabriel Gonzalez
GitHub
parent
5f29cb2905
commit
ff62f3486e
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -100,10 +101,12 @@
|
|||
module Dhall.Import (
|
||||
-- * Import
|
||||
exprFromImport
|
||||
, exprToImport
|
||||
, load
|
||||
, loadWith
|
||||
, hashExpression
|
||||
, hashExpressionToCode
|
||||
, assertNoImports
|
||||
, Status
|
||||
, emptyStatus
|
||||
, stack
|
||||
|
|
@ -113,9 +116,11 @@ module Dhall.Import (
|
|||
, normalizer
|
||||
, startingContext
|
||||
, resolver
|
||||
, cacher
|
||||
, Cycle(..)
|
||||
, ReferentiallyOpaque(..)
|
||||
, Imported(..)
|
||||
, ImportResolutionDisabled(..)
|
||||
, PrettyHttpException(..)
|
||||
, MissingFile(..)
|
||||
, MissingEnvironmentVariable(..)
|
||||
|
|
@ -435,87 +440,101 @@ instance Show HashMismatch where
|
|||
<> "\n"
|
||||
<> "↳ " <> show actualHash <> "\n"
|
||||
|
||||
localToPath :: MonadIO io => FilePrefix -> File -> io FilePath
|
||||
localToPath prefix file_ = liftIO $ do
|
||||
let File {..} = file_
|
||||
|
||||
let Directory {..} = directory
|
||||
|
||||
prefixPath <- case prefix of
|
||||
Home -> do
|
||||
Directory.getHomeDirectory
|
||||
|
||||
Absolute -> do
|
||||
return "/"
|
||||
|
||||
Here -> do
|
||||
Directory.getCurrentDirectory
|
||||
|
||||
let cs = map Text.unpack (file : components)
|
||||
|
||||
let cons component dir = dir </> component
|
||||
|
||||
return (foldr cons prefixPath cs)
|
||||
|
||||
-- | Parse an expression from a `Import` containing a Dhall program
|
||||
exprFromImport :: Import -> StateT (Status IO) IO (Expr Src Import)
|
||||
exprFromImport import_@(Import {..}) = do
|
||||
exprFromImport here@(Import {..}) = do
|
||||
let ImportHashed {..} = importHashed
|
||||
|
||||
case hash of
|
||||
Nothing -> do
|
||||
exprFromUncachedImport import_
|
||||
result <- Maybe.runMaybeT $ do
|
||||
Just expectedHash <- return hash
|
||||
cacheFile <- getCacheFile expectedHash
|
||||
True <- liftIO (Directory.doesPathExist cacheFile)
|
||||
|
||||
Just expectedHash -> do
|
||||
Status {..} <- State.get
|
||||
bytesStrict <- liftIO (Data.ByteString.readFile cacheFile)
|
||||
|
||||
result <- Maybe.runMaybeT (getCacheFile expectedHash)
|
||||
let actualHash = Crypto.Hash.hash bytesStrict
|
||||
|
||||
case result of
|
||||
Just (Read, cacheFile) -> do
|
||||
bytesStrict <- liftIO (Data.ByteString.readFile cacheFile)
|
||||
if expectedHash == actualHash
|
||||
then return ()
|
||||
else liftIO (Control.Exception.throwIO (HashMismatch {..}))
|
||||
|
||||
let actualHash = Crypto.Hash.hash bytesStrict
|
||||
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
|
||||
|
||||
if expectedHash == actualHash
|
||||
then return ()
|
||||
else liftIO (Control.Exception.throwIO (HashMismatch {..}))
|
||||
term <- throws (Codec.Serialise.deserialiseOrFail bytesLazy)
|
||||
|
||||
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
|
||||
throws (Dhall.Binary.decode term)
|
||||
|
||||
term <- case Codec.Serialise.deserialiseOrFail bytesLazy of
|
||||
Left exception ->
|
||||
liftIO (Control.Exception.throwIO exception)
|
||||
case result of
|
||||
Just expression -> return expression
|
||||
Nothing -> exprFromUncachedImport here
|
||||
|
||||
Right term ->
|
||||
return term
|
||||
{-| Save an expression to the specified `Import`
|
||||
|
||||
case Dhall.Binary.decode term of
|
||||
Left exception ->
|
||||
liftIO (Control.Exception.throwIO exception)
|
||||
Currently this only works for cached imports and ignores other types of
|
||||
imports, but could conceivably work for uncached imports in the future
|
||||
|
||||
Right expression ->
|
||||
return expression
|
||||
The main reason for this more general type is for symmetry with
|
||||
`exprFromImport` and to support doing more clever things in the future,
|
||||
like doing \"the right thing\" for uncached imports (i.e. exporting
|
||||
environment variables or creating files)
|
||||
-}
|
||||
exprToImport :: Import -> Expr Src X -> StateT (Status IO) IO ()
|
||||
exprToImport here expression = do
|
||||
Status {..} <- State.get
|
||||
|
||||
Just (Write, cacheFile) -> do
|
||||
expression <- exprFromUncachedImport import_
|
||||
let Import {..} = here
|
||||
|
||||
let _stack' = NonEmpty.cons import_ _stack
|
||||
zoom stack (State.put _stack')
|
||||
resolvedExpression <- loadWith expression
|
||||
zoom stack (State.put _stack)
|
||||
let ImportHashed {..} = importHashed
|
||||
|
||||
case Dhall.TypeCheck.typeWith _startingContext resolvedExpression of
|
||||
Left _ -> do
|
||||
return ()
|
||||
_ <- Maybe.runMaybeT $ do
|
||||
Just expectedHash <- return hash
|
||||
cacheFile <- getCacheFile expectedHash
|
||||
|
||||
Right _ -> do
|
||||
let normalizedExpression =
|
||||
Dhall.Core.alphaNormalize
|
||||
(Dhall.Core.normalizeWith
|
||||
(getReifiedNormalizer _normalizer)
|
||||
resolvedExpression
|
||||
)
|
||||
_ <- throws (Dhall.TypeCheck.typeWith _startingContext expression)
|
||||
|
||||
let bytes =
|
||||
encodeExpression _protocolVersion normalizedExpression
|
||||
let normalizedExpression =
|
||||
Dhall.Core.alphaNormalize
|
||||
(Dhall.Core.normalizeWith
|
||||
(getReifiedNormalizer _normalizer)
|
||||
expression
|
||||
)
|
||||
|
||||
let actualHash = Crypto.Hash.hash bytes
|
||||
let bytes = encodeExpression _protocolVersion normalizedExpression
|
||||
|
||||
if expectedHash == actualHash
|
||||
then return ()
|
||||
else liftIO (Control.Exception.throwIO (HashMismatch {..}))
|
||||
let actualHash = Crypto.Hash.hash bytes
|
||||
|
||||
liftIO (Data.ByteString.writeFile cacheFile bytes)
|
||||
if expectedHash == actualHash
|
||||
then return ()
|
||||
else liftIO (Control.Exception.throwIO (HashMismatch {..}))
|
||||
|
||||
return expression
|
||||
liftIO (Data.ByteString.writeFile cacheFile bytes)
|
||||
|
||||
Nothing -> do
|
||||
exprFromUncachedImport import_
|
||||
|
||||
data CacheMode = Read | Write
|
||||
return ()
|
||||
|
||||
getCacheFile
|
||||
:: (Alternative m, MonadIO m)
|
||||
=> Crypto.Hash.Digest SHA256 -> m (CacheMode, FilePath)
|
||||
:: (Alternative m, MonadIO m) => Crypto.Hash.Digest SHA256 -> m FilePath
|
||||
getCacheFile hash = do
|
||||
let assertDirectory directory = do
|
||||
let private = transform Directory.emptyPermissions
|
||||
|
|
@ -555,41 +574,15 @@ getCacheFile hash = do
|
|||
|
||||
let cacheFile = dhallDirectory </> show hash
|
||||
|
||||
cacheFileExists <- liftIO (Directory.doesPathExist cacheFile)
|
||||
|
||||
if cacheFileExists
|
||||
then do
|
||||
True <- liftIO (Directory.doesFileExist cacheFile)
|
||||
|
||||
return (Read, cacheFile)
|
||||
|
||||
else do
|
||||
return (Write, cacheFile)
|
||||
return cacheFile
|
||||
|
||||
exprFromUncachedImport :: Import -> StateT (Status IO) IO (Expr Src Import)
|
||||
exprFromUncachedImport (Import {..}) = do
|
||||
let ImportHashed {..} = importHashed
|
||||
|
||||
(path, text) <- case importType of
|
||||
Local prefix (File {..}) -> liftIO $ do
|
||||
let Directory {..} = directory
|
||||
|
||||
prefixPath <- case prefix of
|
||||
Home -> do
|
||||
Directory.getHomeDirectory
|
||||
|
||||
Absolute -> do
|
||||
return "/"
|
||||
|
||||
Here -> do
|
||||
Directory.getCurrentDirectory
|
||||
|
||||
let cs = map Text.unpack (file : components)
|
||||
|
||||
let cons component dir = dir </> component
|
||||
|
||||
let path = foldr cons prefixPath cs
|
||||
|
||||
Local prefix file -> liftIO $ do
|
||||
path <- localToPath prefix file
|
||||
exists <- Directory.doesFileExist path
|
||||
|
||||
if exists
|
||||
|
|
@ -681,7 +674,7 @@ exprFromUncachedImport (Import {..}) = do
|
|||
|
||||
-- | Default starting `Status`, importing relative to the given directory.
|
||||
emptyStatus :: FilePath -> Status IO
|
||||
emptyStatus = emptyStatusWith exprFromImport
|
||||
emptyStatus = emptyStatusWith exprFromImport exprToImport
|
||||
|
||||
{-| Generalized version of `load`
|
||||
|
||||
|
|
@ -750,6 +743,8 @@ loadWith expr₀ = case expr₀ of
|
|||
expr'' <- loadWith expr'
|
||||
zoom stack (State.put imports)
|
||||
|
||||
_cacher here expr''
|
||||
|
||||
-- Type-check expressions here for three separate reasons:
|
||||
--
|
||||
-- * to verify that they are closed
|
||||
|
|
@ -881,3 +876,18 @@ hashExpression _protocolVersion expression =
|
|||
hashExpressionToCode :: ProtocolVersion -> Expr s X -> Text
|
||||
hashExpressionToCode _protocolVersion expr =
|
||||
"sha256:" <> Text.pack (show (hashExpression _protocolVersion expr))
|
||||
|
||||
-- | A call to `assertNoImports` failed because there was at least one import
|
||||
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception)
|
||||
|
||||
instance Show ImportResolutionDisabled where
|
||||
show _ = "\nImport resolution is disabled"
|
||||
|
||||
-- | Assert than an expression is import-free
|
||||
assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src X)
|
||||
assertNoImports expression =
|
||||
throws (traverse (\_ -> Left ImportResolutionDisabled) expression)
|
||||
|
||||
throws :: (Exception e, MonadIO io) => Either e a -> io a
|
||||
throws (Left e) = liftIO (Control.Exception.throwIO e)
|
||||
throws (Right a) = return a
|
||||
|
|
|
|||
|
|
@ -53,14 +53,17 @@ data Status m = Status
|
|||
, _startingContext :: Context (Expr Src X)
|
||||
|
||||
, _resolver :: Import -> StateT (Status m) m (Expr Src Import)
|
||||
|
||||
, _cacher :: Import -> Expr Src X -> StateT (Status m) m ()
|
||||
}
|
||||
|
||||
-- | Default starting `Status` that is polymorphic in the base `Monad`
|
||||
emptyStatusWith
|
||||
:: (Import -> StateT (Status m) m (Expr Src Import))
|
||||
-> (Import -> Expr Src X -> StateT (Status m) m ())
|
||||
-> FilePath
|
||||
-> Status m
|
||||
emptyStatusWith _resolver rootDirectory = Status {..}
|
||||
emptyStatusWith _resolver _cacher rootDirectory = Status {..}
|
||||
where
|
||||
_stack = pure rootImport
|
||||
|
||||
|
|
@ -116,6 +119,11 @@ resolver
|
|||
=> LensLike' f (Status m) (Import -> StateT (Status m) m (Expr Src Import))
|
||||
resolver k s = fmap (\x -> s { _resolver = x }) (k (_resolver s))
|
||||
|
||||
cacher
|
||||
:: Functor f
|
||||
=> LensLike' f (Status m) (Import -> Expr Src X -> StateT (Status m) m ())
|
||||
cacher k s = fmap (\x -> s { _cacher = x }) (k (_cacher s))
|
||||
|
||||
{-| This exception indicates that there was an internal error in Dhall's
|
||||
import-related logic
|
||||
the `expected` type then the `extract` function must succeed. If not, then
|
||||
|
|
|
|||
|
|
@ -172,13 +172,6 @@ parseMode =
|
|||
<> Options.Applicative.metavar "FILE"
|
||||
)
|
||||
|
||||
|
||||
|
||||
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception)
|
||||
|
||||
instance Show ImportResolutionDisabled where
|
||||
show _ = "\nImport resolution is disabled"
|
||||
|
||||
throws :: Exception e => Either e a -> IO a
|
||||
throws (Left e) = Control.Exception.throwIO e
|
||||
throws (Right a) = return a
|
||||
|
|
@ -189,10 +182,6 @@ getExpression = do
|
|||
|
||||
throws (Dhall.Parser.exprFromText "(stdin)" inText)
|
||||
|
||||
assertNoImports :: Expr Src Import -> IO (Expr Src X)
|
||||
assertNoImports expression =
|
||||
throws (traverse (\_ -> Left ImportResolutionDisabled) expression)
|
||||
|
||||
-- | `ParserInfo` for the `Options` type
|
||||
parserInfoOptions :: ParserInfo Options
|
||||
parserInfoOptions =
|
||||
|
|
@ -292,7 +281,7 @@ command (Options {..}) = do
|
|||
Normalize -> do
|
||||
expression <- getExpression
|
||||
|
||||
resolvedExpression <- assertNoImports expression
|
||||
resolvedExpression <- Dhall.Import.assertNoImports expression
|
||||
|
||||
_ <- throws (Dhall.TypeCheck.typeOf resolvedExpression)
|
||||
|
||||
|
|
@ -301,7 +290,7 @@ command (Options {..}) = do
|
|||
Type -> do
|
||||
expression <- getExpression
|
||||
|
||||
resolvedExpression <- assertNoImports expression
|
||||
resolvedExpression <- Dhall.Import.assertNoImports expression
|
||||
|
||||
inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user