{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
module Dhall.Import (
load
, loadRelativeTo
, loadWith
, localToPath
, hashExpression
, hashExpressionToCode
, writeExpressionToSemanticCache
, warnAboutMissingCaches
, assertNoImports
, Status(..)
, SemanticCacheMode(..)
, Chained
, chainedImport
, chainedFromLocalHere
, chainedChangeMode
, emptyStatus
, stack
, cache
, Depends(..)
, graph
, remote
, toHeaders
, normalizer
, startingContext
, chainImport
, ImportSemantics
, Cycle(..)
, ReferentiallyOpaque(..)
, Imported(..)
, ImportResolutionDisabled(..)
, PrettyHttpException(..)
, MissingFile(..)
, MissingEnvironmentVariable(..)
, MissingImports(..)
, HashMismatch(..)
) where
import Control.Applicative (Alternative(..))
import Codec.CBOR.Term (Term(..))
import Control.Exception (Exception, SomeException, IOException, toException)
import Control.Monad (when)
import Control.Monad.Catch (throwM, MonadCatch(catch), handle)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Void (Void, absurd)
#if MIN_VERSION_base(4,8,0)
#else
import Data.Traversable (traverse)
#endif
import Data.Typeable (Typeable)
import System.FilePath ((</>))
import Dhall.Binary (StandardVersion(..))
import Dhall.Core
( Expr(..)
, Chunks(..)
, Directory(..)
, File(..)
, FilePrefix(..)
, ImportHashed(..)
, ImportType(..)
, ImportMode(..)
, Import(..)
, URL(..)
, bindingExprs
, chunkExprs
)
#ifdef WITH_HTTP
import Dhall.Import.HTTP hiding (HTTPHeader)
#endif
import Dhall.Import.Types
import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..))
import Lens.Family.State.Strict (zoom)
import qualified Codec.Serialise
import qualified Control.Monad.Trans.Maybe as Maybe
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.CaseInsensitive
import qualified Data.Foldable
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Text.Encoding
import qualified Data.Text as Text
import qualified Data.Text.IO
import qualified Dhall.Binary
import qualified Dhall.Core
import qualified Dhall.Crypto
import qualified Dhall.Map
import qualified Dhall.Parser
import qualified Dhall.Pretty.Internal
import qualified Dhall.TypeCheck
import qualified System.Environment
import qualified System.Info
import qualified System.IO
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified Text.Megaparsec
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token
newtype Cycle = Cycle
{ cyclicImport :: Import
}
deriving (Typeable)
instance Exception Cycle
instance Show Cycle where
show (Cycle import_) =
"\nCyclic import: " ++ Dhall.Pretty.Internal.prettyToString import_
newtype ReferentiallyOpaque = ReferentiallyOpaque
{ opaqueImport :: Import
} deriving (Typeable)
instance Exception ReferentiallyOpaque
instance Show ReferentiallyOpaque where
show (ReferentiallyOpaque import_) =
"\nReferentially opaque import: " ++ Dhall.Pretty.Internal.prettyToString import_
data Imported e = Imported
{ importStack :: NonEmpty Chained
, nested :: e
} deriving (Typeable)
instance Exception e => Exception (Imported e)
instance Show e => Show (Imported e) where
show (Imported canonicalizedImports e) =
concat (zipWith indent [0..] toDisplay)
++ "\n"
++ show e
where
indent n import_ =
"\n" ++ replicate (2 * n) ' ' ++ "↳ " ++ Dhall.Pretty.Internal.prettyToString import_
canonical = NonEmpty.toList canonicalizedImports
toDisplay = drop 1 (reverse canonical)
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
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
newtype MissingImports = MissingImports [SomeException]
instance Exception MissingImports
instance Show MissingImports where
show (MissingImports []) =
"\n"
<> "\ESC[1;31mError\ESC[0m: No valid imports"
show (MissingImports [e]) = show e
show (MissingImports es) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Failed to resolve imports. Error list:"
<> "\n"
<> concatMap (\e -> "\n" <> show e <> "\n") es
throwMissingImport :: (MonadCatch m, Exception e) => e -> m a
throwMissingImport e = throwM (MissingImports [toException e])
type HTTPHeader = (CI ByteString, ByteString)
data CannotImportHTTPURL =
CannotImportHTTPURL
String
(Maybe [HTTPHeader])
deriving (Typeable)
instance Exception CannotImportHTTPURL
instance Show CannotImportHTTPURL where
show (CannotImportHTTPURL url _mheaders) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Cannot import HTTP URL.\n"
<> "\n"
<> "Dhall was compiled without the 'with-http' flag.\n"
<> "\n"
<> "The requested URL was: "
<> url
<> "\n"
class Semigroup path => 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₁)
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 (Remote (URL {..})) =
Remote (URL { path = canonicalize path, headers = fmap (fmap canonicalize) headers, ..})
canonicalize (Env name) =
Env name
canonicalize Missing =
Missing
instance Canonicalize ImportHashed where
canonicalize (ImportHashed hash importType) =
ImportHashed hash (canonicalize importType)
instance Canonicalize Import where
canonicalize (Import importHashed importMode) =
Import (canonicalize importHashed) importMode
data HashMismatch = HashMismatch
{ expectedHash :: Dhall.Crypto.SHA256Digest
, actualHash :: Dhall.Crypto.SHA256Digest
} 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"
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 "/"
Parent -> do
return ".."
Here -> do
return "."
let cs = map Text.unpack (file : components)
let cons component dir = dir </> component
return (foldr cons prefixPath cs)
chainedFromLocalHere :: FilePrefix -> File -> ImportMode -> Chained
chainedFromLocalHere prefix file mode = Chained $
Import (ImportHashed Nothing (Local prefix (canonicalize file))) mode
chainedChangeMode :: ImportMode -> Chained -> Chained
chainedChangeMode mode (Chained (Import importHashed _)) =
Chained (Import importHashed mode)
chainImport :: Chained -> Import -> StateT Status IO Chained
chainImport (Chained parent) child@(Import importHashed@(ImportHashed _ (Remote url)) _) = do
url' <- normalizeHeaders url
let child' = child { importHashed = importHashed { importType = Remote url' } }
return (Chained (canonicalize (parent <> child')))
chainImport (Chained parent) child =
return (Chained (canonicalize (parent <> child)))
loadImport :: Chained -> StateT Status IO ImportSemantics
loadImport import_ = do
Status {..} <- State.get
case Map.lookup import_ _cache of
Just importSemantics -> return importSemantics
Nothing -> do
importSemantics <- loadImportWithSemanticCache import_
zoom cache (State.modify (Map.insert import_ importSemantics))
return importSemantics
loadImportWithSemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache
import_@(Chained (Import (ImportHashed Nothing _) _)) = do
loadImportWithSemisemanticCache import_
loadImportWithSemanticCache
import_@(Chained (Import (ImportHashed (Just semanticHash) _) _)) = do
Status { .. } <- State.get
mCached <-
case _semanticCacheMode of
UseSemanticCache -> liftIO $ fetchFromSemanticCache semanticHash
IgnoreSemanticCache -> pure Nothing
case mCached of
Just bytesStrict -> do
let actualHash = Dhall.Crypto.sha256Hash bytesStrict
if semanticHash == actualHash
then return ()
else do
Status { _stack } <- State.get
throwMissingImport (Imported _stack (HashMismatch {expectedHash = semanticHash, ..}))
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
term <- case Codec.Serialise.deserialiseOrFail bytesLazy of
Left err -> throwMissingImport (Imported _stack err)
Right t -> return t
importSemantics <- case Dhall.Binary.decodeExpression term of
Left err -> throwMissingImport (Imported _stack err)
Right sem -> return sem
return (ImportSemantics {..})
Nothing -> do
ImportSemantics { importSemantics } <- loadImportWithSemisemanticCache import_
let variants = map (\version -> encodeExpression version (Dhall.Core.alphaNormalize importSemantics))
[ minBound .. maxBound ]
case Data.Foldable.find ((== semanticHash). Dhall.Crypto.sha256Hash) variants of
Just bytes -> liftIO $ writeToSemanticCache semanticHash bytes
Nothing -> do
let expectedHash = semanticHash
Status { _stack } <- State.get
let actualHash = hashExpression (Dhall.Core.alphaNormalize importSemantics)
throwMissingImport (Imported _stack (HashMismatch {..}))
return (ImportSemantics {..})
fetchFromSemanticCache :: Dhall.Crypto.SHA256Digest -> IO (Maybe Data.ByteString.ByteString)
fetchFromSemanticCache expectedHash = Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall" expectedHash
True <- liftIO (Directory.doesFileExist cacheFile)
liftIO (Data.ByteString.readFile cacheFile)
writeExpressionToSemanticCache :: Expr Src Void -> IO ()
writeExpressionToSemanticCache expression = writeToSemanticCache hash bytes
where
bytes = encodeExpression NoVersion expression
hash = Dhall.Crypto.sha256Hash bytes
writeToSemanticCache :: Dhall.Crypto.SHA256Digest -> Data.ByteString.ByteString -> IO ()
writeToSemanticCache hash bytes = do
_ <- Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall" hash
liftIO (Data.ByteString.writeFile cacheFile bytes)
return ()
loadImportWithSemisemanticCache
:: Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Code)) = do
text <- fetchFresh importType
Status {..} <- State.get
path <- case importType of
Local prefix file -> liftIO $ do
path <- localToPath prefix file
absolutePath <- Directory.makeAbsolute path
return absolutePath
Remote url -> do
let urlText = Dhall.Core.pretty (url { headers = Nothing })
return (Text.unpack urlText)
Env env -> return $ Text.unpack env
Missing -> throwM (MissingImports [])
let parser = unParser $ do
Text.Parser.Token.whiteSpace
r <- Dhall.Parser.expr
Text.Parser.Combinators.eof
return r
parsedImport <- case Text.Megaparsec.parse parser path text of
Left errInfo -> do
throwMissingImport (Imported _stack (ParseError errInfo text))
Right expr -> return expr
resolvedExpr <- loadWith parsedImport
let semisemanticHash = computeSemisemanticHash resolvedExpr
mCached <- lift $ fetchFromSemisemanticCache semisemanticHash
importSemantics <- case mCached of
Just bytesStrict -> do
let bytesLazy = Data.ByteString.Lazy.fromStrict bytesStrict
term <- case Codec.Serialise.deserialiseOrFail bytesLazy of
Left err -> throwMissingImport (Imported _stack err)
Right t -> return t
importSemantics <- case Dhall.Binary.decodeExpression term of
Left err -> throwMissingImport (Imported _stack err)
Right sem -> return sem
return importSemantics
Nothing -> do
betaNormal <- case Dhall.TypeCheck.typeWith _startingContext resolvedExpr of
Left err -> throwMissingImport (Imported _stack err)
Right _ -> return (Dhall.Core.normalizeWith _normalizer resolvedExpr)
let bytes = encodeExpression NoVersion betaNormal
lift $ writeToSemisemanticCache semisemanticHash bytes
return betaNormal
return (ImportSemantics {..})
loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) RawText)) = do
text <- fetchFresh importType
let importSemantics = TextLit (Chunks [] text)
return (ImportSemantics {..})
loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Location)) = do
let locationType = Union $ Dhall.Map.fromList
[ ("Environment", Just Text)
, ("Remote", Just Text)
, ("Local", Just Text)
, ("Missing", Nothing)
]
let importSemantics = case importType of
Missing -> Field locationType "Missing"
local@(Local _ _) ->
App (Field locationType "Local")
(TextLit (Chunks [] (Dhall.Core.pretty local)))
remote_@(Remote _) ->
App (Field locationType "Remote")
(TextLit (Chunks [] (Dhall.Core.pretty remote_)))
Env env ->
App (Field locationType "Environment")
(TextLit (Chunks [] (Dhall.Core.pretty env)))
return (ImportSemantics {..})
computeSemisemanticHash :: Expr Src Void -> Dhall.Crypto.SHA256Digest
computeSemisemanticHash resolvedExpr = hashExpression resolvedExpr
fetchFromSemisemanticCache :: Dhall.Crypto.SHA256Digest -> IO (Maybe Data.ByteString.ByteString)
fetchFromSemisemanticCache semisemanticHash = Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall-haskell" semisemanticHash
True <- liftIO (Directory.doesFileExist cacheFile)
liftIO (Data.ByteString.readFile cacheFile)
writeToSemisemanticCache :: Dhall.Crypto.SHA256Digest -> Data.ByteString.ByteString -> IO ()
writeToSemisemanticCache semisemanticHash bytes = do
_ <- Maybe.runMaybeT $ do
cacheFile <- getCacheFile "dhall-haskell" semisemanticHash
liftIO (Data.ByteString.writeFile cacheFile bytes)
return ()
fetchFresh :: ImportType -> StateT Status IO Text
fetchFresh (Local prefix file) = do
Status { _stack } <- State.get
path <- liftIO $ localToPath prefix file
exists <- liftIO $ Directory.doesFileExist path
if exists
then liftIO $ Data.Text.IO.readFile path
else throwMissingImport (Imported _stack (MissingFile path))
fetchFresh (Remote url) = do
Status { _remote } <- State.get
_remote url
fetchFresh (Env env) = do
Status { _stack } <- State.get
x <- liftIO $ System.Environment.lookupEnv (Text.unpack env)
case x of
Just string -> do
return (Text.pack string)
Nothing -> do
throwMissingImport (Imported _stack (MissingEnvironmentVariable env))
fetchFresh Missing = throwM (MissingImports [])
fetchRemote :: URL -> StateT Status IO Data.Text.Text
#ifndef WITH_HTTP
fetchRemote (url@URL { headers = maybeHeadersExpression }) = do
let maybeHeaders = fmap toHeaders maybeHeadersExpression
let urlString = Text.unpack (Dhall.Core.pretty url)
Status { _stack } <- State.get
throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders))
#else
fetchRemote url = do
zoom remote (State.put fetchFromHTTP)
fetchFromHTTP url
where
fetchFromHTTP :: URL -> StateT Status IO Data.Text.Text
fetchFromHTTP (url'@URL { headers = maybeHeadersExpression }) = do
let maybeHeaders = fmap toHeaders maybeHeadersExpression
fetchFromHttpUrl url' maybeHeaders
#endif
toHeaders :: Expr s a -> [HTTPHeader]
toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders)
where
maybeHeaders = mapM toHeader hs
toHeaders _ = []
toHeader :: Expr s a -> Maybe HTTPHeader
toHeader (RecordLit m) = do
TextLit (Chunks [] keyText ) <-
Dhall.Map.lookup "header" m <|> Dhall.Map.lookup "mapKey" m
TextLit (Chunks [] valueText) <-
Dhall.Map.lookup "value" m <|> Dhall.Map.lookup "mapValue" m
let keyBytes = Data.Text.Encoding.encodeUtf8 keyText
let valueBytes = Data.Text.Encoding.encodeUtf8 valueText
return (Data.CaseInsensitive.mk keyBytes, valueBytes)
toHeader _ = do
empty
getCacheFile
:: (MonadCatch m, Alternative m, MonadIO m) => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
getCacheFile cacheName hash = do
cacheDirectory <- getOrCreateCacheDirectory False cacheName
let cacheFile = cacheDirectory </> ("1220" <> show hash)
return cacheFile
warnAboutMissingCaches :: (MonadCatch m, Alternative m, MonadIO m) => m ()
warnAboutMissingCaches = warn <|> return ()
where warn = Data.Foldable.traverse_ (getOrCreateCacheDirectory True) ["dhall", "dhall-haskell"]
getOrCreateCacheDirectory :: (MonadCatch m, Alternative m, MonadIO m) => Bool -> FilePath -> m FilePath
getOrCreateCacheDirectory showWarning cacheName = do
let warn message = do
let warning =
"\n"
<> "\ESC[1;33mWarning\ESC[0m: "
<> message
when showWarning (liftIO (System.IO.hPutStrLn System.IO.stderr warning))
empty
let handler action dir (ioex :: IOException) = do
let ioExMsg =
"When trying to " <> action <> ":\n"
<> "\n"
<> "↳ " <> dir <> "\n"
<> "\n"
<> "... the following exception was thrown:\n"
<> "\n"
<> "↳ " <> show ioex <> "\n"
warn ioExMsg
let setPermissions dir = do
let private = transform Directory.emptyPermissions
where
transform =
Directory.setOwnerReadable True
. Directory.setOwnerWritable True
. Directory.setOwnerSearchable True
catch
(liftIO (Directory.setPermissions dir private))
(handler "correct the permissions for" dir)
let assertPermissions dir = do
let accessible path =
Directory.readable path
&& Directory.writable path
&& Directory.searchable path
permissions <-
catch (liftIO (Directory.getPermissions dir))
(handler "get permissions of" dir)
if accessible permissions
then
return ()
else do
let message =
"The directory:\n"
<> "\n"
<> "↳ " <> dir <> "\n"
<> "\n"
<> "... does not give you permission to read, write, or search files.\n\n"
<> "The directory's current permissions are:\n"
<> show permissions <> "\n"
warn message
let existsDirectory dir =
catch (liftIO (Directory.doesDirectoryExist dir))
(handler "check the existence of" dir)
let existsFile path =
catch (liftIO (Directory.doesFileExist path))
(handler "check the existence of" path)
let createDirectory dir =
catch (liftIO (Directory.createDirectory dir))
(handler "create" dir)
let assertDirectory dir = do
existsDir <- existsDirectory dir
if existsDir
then do
assertPermissions dir
else do
existsFile' <- existsFile dir
if existsFile'
then do
let message =
"The given path:\n"
<> "\n"
<> "↳ " <> dir <> "\n"
<> "\n"
<> "... already exists but is not a directory.\n"
warn message
else do
assertDirectory (FilePath.takeDirectory dir)
createDirectory dir
setPermissions dir
cacheBaseDirectory <- getCacheBaseDirectory showWarning
let directory = cacheBaseDirectory </> cacheName
let message =
"Could not get or create the default cache directory:\n"
<> "\n"
<> "↳ " <> directory <> "\n"
<> "\n"
<> "You can enable caching by creating it if needed and setting read,\n"
<> "write and search permissions on it or providing another cache base\n"
<> "directory by setting the $XDG_CACHE_HOME environment variable.\n"
<> "\n"
assertDirectory directory <|> warn message
return directory
getCacheBaseDirectory :: (Alternative m, MonadIO m) => Bool -> m FilePath
getCacheBaseDirectory showWarning = alternative₀ <|> alternative₁ <|> alternative₂
where
alternative₀ = do
maybeXDGCacheHome <- do
liftIO (System.Environment.lookupEnv "XDG_CACHE_HOME")
case maybeXDGCacheHome of
Just xdgCacheHome -> return xdgCacheHome
Nothing -> empty
alternative₁
| isWindows = do
maybeLocalAppDirectory <-
liftIO (System.Environment.lookupEnv "LOCALAPPDATA")
case maybeLocalAppDirectory of
Just localAppDirectory -> return localAppDirectory
Nothing -> empty
| otherwise = do
maybeHomeDirectory <-
liftIO (System.Environment.lookupEnv "HOME")
case maybeHomeDirectory of
Just homeDirectory -> return (homeDirectory </> ".cache")
Nothing -> empty
where isWindows = System.Info.os == "mingw32"
alternative₂ = do
let message =
"\n"
<> "\ESC[1;33mWarning\ESC[0m: "
<> "Could not locate a cache base directory from the environment.\n"
<> "\n"
<> "You can provide a cache base directory by pointing the $XDG_CACHE_HOME\n"
<> "environment variable to a directory with read and write permissions.\n"
when showWarning (liftIO (System.IO.hPutStrLn System.IO.stderr message))
empty
normalizeHeaders :: URL -> StateT Status IO URL
normalizeHeaders url@URL { headers = Just headersExpression } = do
Status { _stack } <- State.get
loadedExpr <- loadWith headersExpression
let go key₀ key₁ = do
let expected :: Expr Src Void
expected =
App List
( Record
( Dhall.Map.fromList
[ (key₀, Text), (key₁, Text) ]
)
)
let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected
let annot = case loadedExpr of
Note (Src begin end bytes) _ ->
Note (Src begin end bytes') (Annot loadedExpr expected)
where
bytes' = bytes <> " : " <> suffix_
_ ->
Annot loadedExpr expected
_ <- case (Dhall.TypeCheck.typeOf annot) of
Left err -> throwMissingImport (Imported _stack err)
Right _ -> return ()
return (Dhall.Core.normalize loadedExpr)
let handler₀ (e :: SomeException) = do
let handler₁ (_ :: SomeException) =
throwMissingImport (Imported _stack e)
handle handler₁ (go "header" "value")
headersExpression' <-
handle handler₀ (go "mapKey" "mapValue")
return url { headers = Just (fmap absurd headersExpression') }
normalizeHeaders url = return url
emptyStatus :: FilePath -> Status
emptyStatus = emptyStatusWith fetchRemote
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith expr₀ = case expr₀ of
Embed import₀ -> do
Status {..} <- State.get
let parent = NonEmpty.head _stack
child <- chainImport parent import₀
let local (Chained (Import (ImportHashed _ (Remote {})) _)) = False
local (Chained (Import (ImportHashed _ (Local {})) _)) = True
local (Chained (Import (ImportHashed _ (Env {})) _)) = True
local (Chained (Import (ImportHashed _ (Missing {})) _)) = True
let referentiallySane = not (local child) || local parent
if referentiallySane
then return ()
else throwMissingImport (Imported _stack (ReferentiallyOpaque import₀))
let _stack' = NonEmpty.cons child _stack
if child `elem` _stack
then throwMissingImport (Imported _stack (Cycle import₀))
else return ()
zoom graph . State.modify $
\edges -> Depends parent child : edges
let stackWithChild = NonEmpty.cons child _stack
zoom stack (State.put stackWithChild)
ImportSemantics {..} <- loadImport child
zoom stack (State.put _stack)
return importSemantics
ImportAlt a b -> loadWith a `catch` handler₀
where
handler₀ (SourcedException (Src begin _ text₀) (MissingImports es₀)) =
loadWith b `catch` handler₁
where
handler₁ (SourcedException (Src _ end text₁) (MissingImports es₁)) =
throwM (SourcedException (Src begin end text₂) (MissingImports (es₀ ++ es₁)))
where
text₂ = text₀ <> " ? " <> text₁
Const a -> pure (Const a)
Var a -> pure (Var a)
Lam a b c -> Lam <$> pure a <*> loadWith b <*> loadWith c
Pi a b c -> Pi <$> pure a <*> loadWith b <*> loadWith c
App a b -> App <$> loadWith a <*> loadWith b
Let a b -> Let <$> bindingExprs loadWith a <*> loadWith b
Annot a b -> Annot <$> loadWith a <*> loadWith b
Bool -> pure Bool
BoolLit a -> pure (BoolLit a)
BoolAnd a b -> BoolAnd <$> loadWith a <*> loadWith b
BoolOr a b -> BoolOr <$> loadWith a <*> loadWith b
BoolEQ a b -> BoolEQ <$> loadWith a <*> loadWith b
BoolNE a b -> BoolNE <$> loadWith a <*> loadWith b
BoolIf a b c -> BoolIf <$> loadWith a <*> loadWith b <*> loadWith c
Natural -> pure Natural
NaturalLit a -> pure (NaturalLit a)
NaturalFold -> pure NaturalFold
NaturalBuild -> pure NaturalBuild
NaturalIsZero -> pure NaturalIsZero
NaturalEven -> pure NaturalEven
NaturalOdd -> pure NaturalOdd
NaturalToInteger -> pure NaturalToInteger
NaturalShow -> pure NaturalShow
NaturalSubtract -> pure NaturalSubtract
NaturalPlus a b -> NaturalPlus <$> loadWith a <*> loadWith b
NaturalTimes a b -> NaturalTimes <$> loadWith a <*> loadWith b
Integer -> pure Integer
IntegerLit a -> pure (IntegerLit a)
IntegerShow -> pure IntegerShow
IntegerToDouble -> pure IntegerToDouble
Double -> pure Double
DoubleLit a -> pure (DoubleLit a)
DoubleShow -> pure DoubleShow
Text -> pure Text
TextLit chunks -> TextLit <$> chunkExprs loadWith chunks
TextAppend a b -> TextAppend <$> loadWith a <*> loadWith b
TextShow -> pure TextShow
List -> pure List
ListLit a b -> ListLit <$> mapM loadWith a <*> mapM loadWith b
ListAppend a b -> ListAppend <$> loadWith a <*> loadWith b
ListBuild -> pure ListBuild
ListFold -> pure ListFold
ListLength -> pure ListLength
ListHead -> pure ListHead
ListLast -> pure ListLast
ListIndexed -> pure ListIndexed
ListReverse -> pure ListReverse
Optional -> pure Optional
None -> pure None
Some a -> Some <$> loadWith a
OptionalFold -> pure OptionalFold
OptionalBuild -> pure OptionalBuild
Record a -> Record <$> mapM loadWith a
RecordLit a -> RecordLit <$> mapM loadWith a
Union a -> Union <$> mapM (mapM loadWith) a
Combine a b -> Combine <$> loadWith a <*> loadWith b
CombineTypes a b -> CombineTypes <$> loadWith a <*> loadWith b
Prefer a b -> Prefer <$> loadWith a <*> loadWith b
RecordCompletion a b -> RecordCompletion <$> loadWith a <*> loadWith b
Merge a b c -> Merge <$> loadWith a <*> loadWith b <*> mapM loadWith c
ToMap a b -> ToMap <$> loadWith a <*> mapM loadWith b
Field a b -> Field <$> loadWith a <*> pure b
Project a b -> Project <$> loadWith a <*> mapM loadWith b
Assert a -> Assert <$> loadWith a
Equivalent a b -> Equivalent <$> loadWith a <*> loadWith b
Note a b -> do
let handler e = throwM (SourcedException a (e :: MissingImports))
(Note <$> pure a <*> loadWith b) `catch` handler
load :: Expr Src Import -> IO (Expr Src Void)
load = loadRelativeTo "." UseSemanticCache
loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo rootDirectory semanticCacheMode expression =
State.evalStateT
(loadWith expression)
(emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode }
encodeExpression
:: forall s
. StandardVersion
-> Expr s Void
-> Data.ByteString.ByteString
encodeExpression _standardVersion expression = bytesStrict
where
intermediateExpression :: Expr s Import
intermediateExpression = fmap absurd expression
term :: Term
term = Dhall.Binary.encodeExpression intermediateExpression
taggedTerm :: Term
taggedTerm =
case _standardVersion of
NoVersion -> term
s -> TList [ TString v, term ]
where
v = Dhall.Binary.renderStandardVersion s
bytesLazy = Codec.Serialise.serialise taggedTerm
bytesStrict = Data.ByteString.Lazy.toStrict bytesLazy
hashExpression :: Expr s Void -> Dhall.Crypto.SHA256Digest
hashExpression expression =
Dhall.Crypto.sha256Hash (encodeExpression NoVersion expression)
hashExpressionToCode :: Expr s Void -> Text
hashExpressionToCode expr =
"sha256:" <> Text.pack (show (hashExpression expr))
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception)
instance Show ImportResolutionDisabled where
show _ = "\nImport resolution is disabled"
assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src Void)
assertNoImports expression =
Dhall.Core.throws (traverse (\_ -> Left ImportResolutionDisabled) expression)