{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

{-# OPTIONS_GHC -Wall #-}

{-| Dhall lets you import external expressions located either in local files or
    hosted on network endpoints.

    To import a local file as an expression, just insert the path to the file,
    prepending a @./@ if the path is relative to the current directory.  For
    example, if you create a file named @id@ with the following contents:

    > $ cat id
    > λ(a : Type) → λ(x : a) → x

    Then you can use the file directly within a @dhall@ program just by
    referencing the file's path:

    > $ dhall
    > ./id Bool True
    > <Ctrl-D>
    > Bool
    >
    > True

    Imported expressions may contain imports of their own, too, which will
    continue to be resolved.  However, Dhall will prevent cyclic imports.  For
    example, if you had these two files:

    > $ cat foo
    > ./bar

    > $ cat bar
    > ./foo

    ... Dhall would throw the following exception if you tried to import @foo@:

    > $ dhall
    > ./foo
    > ^D
    > ↳ ./foo
    >   ↳ ./bar
    >
    > Cyclic import: ./foo

    You can also import expressions hosted on network endpoints.  Just use the
    URL

    > http://host[:port]/path

    The compiler expects the downloaded expressions to be in the same format
    as local files, specifically UTF8-encoded source code text.

    For example, if our @id@ expression were hosted at @http://example.com/id@,
    then we would embed the expression within our code using:

    > http://example.com/id

    You can also import expressions stored within environment variables using
    @env:NAME@, where @NAME@ is the name of the environment variable.  For
    example:

    > $ export FOO=1
    > $ export BAR='"Hi"'
    > $ export BAZ='λ(x : Bool) → x == False'
    > $ dhall <<< "{ foo = env:FOO , bar = env:BAR , baz = env:BAZ }"
    > { bar : Text, baz : ∀(x : Bool) → Bool, foo : Integer }
    >
    > { bar = "Hi", baz = λ(x : Bool) → x == False, foo = 1 }

    If you wish to import the raw contents of an impoert as @Text@ then add
    @as Text@ to the end of the import:

    > $ dhall <<< "http://example.com as Text"
    > Text
    >
    > "<!doctype html>\n<html>\n<head>\n    <title>Example Domain</title>\n\n    <meta
    >  charset=\"utf-8\" />\n    <meta http-equiv=\"Content-type\" content=\"text/html
    > ; charset=utf-8\" />\n    <meta name=\"viewport\" content=\"width=device-width,
    > initial-scale=1\" />\n    <style type=\"text/css\">\n    body {\n        backgro
    > und-color: #f0f0f2;\n        margin: 0;\n        padding: 0;\n        font-famil
    > y: \"Open Sans\", \"Helvetica Neue\", Helvetica, Arial, sans-serif;\n        \n
    >    }\n    div {\n        width: 600px;\n        margin: 5em auto;\n        paddi
    > ng: 50px;\n        background-color: #fff;\n        border-radius: 1em;\n    }\n
    >     a:link, a:visited {\n        color: #38488f;\n        text-decoration: none;
    > \n    }\n    @media (max-width: 700px) {\n        body {\n            background
    > -color: #fff;\n        }\n        div {\n            width: auto;\n            m
    > argin: 0 auto;\n            border-radius: 0;\n            padding: 1em;\n
    >   }\n    }\n    </style>    \n</head>\n\n<body>\n<div>\n    <h1>Example Domain</
    > h1>\n    <p>This domain is established to be used for illustrative examples in d
    > ocuments. You may use this\n    domain in examples without prior coordination or
    >  asking for permission.</p>\n    <p><a href=\"http://www.iana.org/domains/exampl
    > e\">More information...</a></p>\n</div>\n</body>\n</html>\n"
-}

module Dhall.Import (
    -- * Import
      load
    , loadWithManager
    , loadRelativeTo
    , loadWithStatus
    , loadWith
    , localToPath
    , hashExpression
    , hashExpressionToCode
    , writeExpressionToSemanticCache
    , assertNoImports
    , Manager
    , defaultNewManager
    , CacheWarning(..)
    , Status(..)
    , SemanticCacheMode(..)
    , Chained
    , chainedImport
    , chainedFromLocalHere
    , chainedChangeMode
    , emptyStatus
    , emptyStatusWithManager
    , envOriginHeaders
    , makeEmptyStatus
    , remoteStatus
    , remoteStatusWithManager
    , fetchRemote
    , stack
    , cache
    , Depends(..)
    , graph
    , remote
    , toHeaders
    , substitutions
    , normalizer
    , startingContext
    , chainImport
    , dependencyToFile
    , ImportSemantics
    , HTTPHeader
    , Cycle(..)
    , ReferentiallyOpaque(..)
    , Imported(..)
    , ImportResolutionDisabled(..)
    , PrettyHttpException(..)
    , MissingFile(..)
    , MissingEnvironmentVariable(..)
    , MissingImports(..)
    , HashMismatch(..)
    ) where

import Control.Applicative        (Alternative (..))
import Control.Exception
    ( Exception
    , IOException
    , SomeException
    , toException
    )
import Control.Monad.Catch        (MonadCatch (catch), handle, throwM)
import Control.Monad.IO.Class     (MonadIO (..))
import Control.Monad.Morph        (hoist)
import Control.Monad.State.Strict (MonadState, StateT)
import Data.ByteString            (ByteString)
import Data.List.NonEmpty         (NonEmpty (..), nonEmpty)
import Data.Maybe                 (fromMaybe)
import Data.Text                  (Text)
import Data.Typeable              (Typeable)
import Data.Void                  (Void, absurd)
import Dhall.TypeCheck            (TypeError)

import Dhall.Syntax
    ( Chunks (..)
    , Directory (..)
    , Expr (..)
    , File (..)
    , FilePrefix (..)
    , Import (..)
    , ImportHashed (..)
    , ImportMode (..)
    , ImportType (..)
    , URL (..)
    , bindingExprs
    , functionBindingExprs
    , recordFieldExprs
    )

import System.FilePath ((</>))
import Text.Megaparsec (SourcePos (SourcePos), mkPos)

#ifdef WITH_HTTP
import Dhall.Import.HTTP
#endif
import Dhall.Import.Headers
    ( normalizeHeaders
    , originHeadersTypeExpr
    , toHeaders
    , toOriginHeaders
    )
import Dhall.Import.Types

import Dhall.Parser
    ( ParseError (..)
    , Parser (..)
    , SourcedException (..)
    , Src (..)
    )
import Lens.Family.State.Strict (zoom)

import qualified Codec.CBOR.Write                            as Write
import qualified Codec.Serialise
import qualified Control.Exception                           as Exception
import qualified Control.Monad.State.Strict                  as State
import qualified Control.Monad.Trans.Maybe                   as Maybe
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.List.NonEmpty                          as NonEmpty
import qualified Data.Maybe                                  as Maybe
import qualified Data.Text                                   as Text
import qualified Data.Text.IO
import qualified Dhall.Binary
import qualified Dhall.Core                                  as Core
import qualified Dhall.Crypto
import qualified Dhall.Map
import qualified Dhall.Parser
import qualified Dhall.Pretty.Internal
import qualified Dhall.Substitution
import qualified Dhall.Syntax                                as Syntax
import qualified Dhall.TypeCheck
import qualified System.AtomicWrite.Writer.ByteString.Binary as AtomicWrite.Binary
import qualified System.Directory                            as Directory
import qualified System.Environment
import qualified System.FilePath                             as FilePath
import qualified System.IO
import qualified System.Info
import qualified Text.Megaparsec
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token

{- $setup

    >>> import Dhall.Syntax
-}

-- | An import failed because of a cycle in the import graph
newtype Cycle = Cycle
    { Cycle -> Import
cyclicImport :: Import  -- ^ The offending cyclic import
    }
  deriving (Typeable)

instance Exception Cycle

instance Show Cycle where
    show :: Cycle -> String
show (Cycle Import
import_) =
        String
"\nCyclic import: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Import -> String
forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString Import
import_

{-| Dhall tries to ensure that all expressions hosted on network endpoints are
    weakly referentially transparent, meaning roughly that any two clients will
    compile the exact same result given the same URL.

    To be precise, a strong interpretaton of referential transparency means that
    if you compiled a URL you could replace the expression hosted at that URL
    with the compiled result.  Let's call this \"static linking\".  Dhall (very
    intentionally) does not satisfy this stronger interpretation of referential
    transparency since \"statically linking\" an expression (i.e. permanently
    resolving all imports) means that the expression will no longer update if
    its dependencies change.

    In general, either interpretation of referential transparency is not
    enforceable in a networked context since one can easily violate referential
    transparency with a custom DNS, but Dhall can still try to guard against
    common unintentional violations.  To do this, Dhall enforces that a
    non-local import may not reference a local import.

    Local imports are defined as:

    * A file

    * A URL with a host of @localhost@ or @127.0.0.1@

    All other imports are defined to be non-local
-}
newtype ReferentiallyOpaque = ReferentiallyOpaque
    { ReferentiallyOpaque -> Import
opaqueImport :: Import  -- ^ The offending opaque import
    } deriving (Typeable)

instance Exception ReferentiallyOpaque

instance Show ReferentiallyOpaque where
    show :: ReferentiallyOpaque -> String
show (ReferentiallyOpaque Import
import_) =
        String
"\nLocal imports are not permitted from remote imports: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Import -> String
forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString Import
import_

-- | Extend another exception with the current import stack
data Imported e = Imported
    { Imported e -> NonEmpty Chained
importStack :: NonEmpty Chained  -- ^ Imports resolved so far, in reverse order
    , Imported e -> e
nested      :: e                 -- ^ The nested exception
    } deriving (Typeable)

instance Exception e => Exception (Imported e)

instance Show e => Show (Imported e) where
    show :: Imported e -> String
show (Imported NonEmpty Chained
canonicalizedImports e
e) =
           [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> Chained -> String) -> [Int] -> [Chained] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Chained -> String
forall a. Pretty a => Int -> a -> String
indent [Int
0..] [Chained]
toDisplay)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e
      where
        indent :: Int -> a -> String
indent Int
n a
import_ =
            String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"↳ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
Dhall.Pretty.Internal.prettyToString a
import_

        canonical :: [Chained]
canonical = NonEmpty Chained -> [Chained]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Chained
canonicalizedImports

        -- Tthe final (outermost) import is fake to establish the base
        -- directory. Also, we need outermost-first.
        toDisplay :: [Chained]
toDisplay = Int -> [Chained] -> [Chained]
forall a. Int -> [a] -> [a]
drop Int
1 ([Chained] -> [Chained]
forall a. [a] -> [a]
reverse [Chained]
canonical)

-- | Exception thrown when an imported file is missing
newtype MissingFile = MissingFile FilePath
    deriving (Typeable)

instance Exception MissingFile

instance Show MissingFile where
    show :: MissingFile -> String
show (MissingFile String
path) =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: Missing file "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
path

-- | Exception thrown when an environment variable is missing
newtype MissingEnvironmentVariable = MissingEnvironmentVariable { MissingEnvironmentVariable -> Text
name :: Text }
    deriving (Typeable)

instance Exception MissingEnvironmentVariable

instance Show MissingEnvironmentVariable where
    show :: MissingEnvironmentVariable -> String
show MissingEnvironmentVariable{Text
name :: Text
name :: MissingEnvironmentVariable -> Text
..} =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: Missing environment variable\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name

-- | List of Exceptions we encounter while resolving Import Alternatives
newtype MissingImports = MissingImports [SomeException]

instance Exception MissingImports

instance Show MissingImports where
    show :: MissingImports -> String
show (MissingImports []) =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: No valid imports"
    show (MissingImports [SomeException
e]) = SomeException -> String
forall a. Show a => a -> String
show SomeException
e
    show (MissingImports [SomeException]
es) =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: Failed to resolve imports. Error list:"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  (SomeException -> String) -> [SomeException] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\SomeException
e -> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n") [SomeException]
es

throwMissingImport :: (MonadCatch m, Exception e) => e -> m a
throwMissingImport :: e -> m a
throwMissingImport e
e = MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e])

-- | Exception thrown when a HTTP url is imported but dhall was built without
-- the @with-http@ Cabal flag.
data CannotImportHTTPURL =
    CannotImportHTTPURL
        String
        (Maybe [HTTPHeader])
    deriving (Typeable)

instance Exception CannotImportHTTPURL

instance Show CannotImportHTTPURL where
    show :: CannotImportHTTPURL -> String
show (CannotImportHTTPURL String
url Maybe [HTTPHeader]
_mheaders) =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: Cannot import HTTP URL.\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"Dhall was compiled without the 'with-http' flag.\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"The requested URL was: "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
url
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"

{-|
> canonicalize . canonicalize = canonicalize

> canonicalize (a <> b) = canonicalize (canonicalize a <> canonicalize b)
-}
class Semigroup path => Canonicalize path where
    canonicalize :: path -> path

-- |
-- >>> canonicalize (Directory {components = ["..",".."]})
-- Directory {components = ["..",".."]}
instance Canonicalize Directory where
    canonicalize :: Directory -> Directory
canonicalize (Directory []) = [Text] -> Directory
Directory []

    canonicalize (Directory (Text
"." : [Text]
components₀)) =
        Directory -> Directory
forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀)

    canonicalize (Directory (Text
".." : [Text]
components₀)) =
        case Directory -> Directory
forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀) of
            Directory [] ->
                [Text] -> Directory
Directory [ Text
".." ]
            Directory (Text
".." : [Text]
components₁) ->
                [Text] -> Directory
Directory (Text
".." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
".." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
components₁)
            Directory (Text
_    : [Text]
components₁) ->
                [Text] -> Directory
Directory [Text]
components₁

    canonicalize (Directory (Text
component : [Text]
components₀)) =
        [Text] -> Directory
Directory (Text
component Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
components₁)
      where
        Directory [Text]
components₁ = Directory -> Directory
forall path. Canonicalize path => path -> path
canonicalize ([Text] -> Directory
Directory [Text]
components₀)

instance Canonicalize File where
    canonicalize :: File -> File
canonicalize (File { Directory
directory :: File -> Directory
directory :: Directory
directory, Text
file :: File -> Text
file :: Text
.. }) =
        File :: Directory -> Text -> File
File { directory :: Directory
directory = Directory -> Directory
forall path. Canonicalize path => path -> path
canonicalize Directory
directory, Text
file :: Text
file :: Text
.. }

instance Canonicalize ImportType where
    canonicalize :: ImportType -> ImportType
canonicalize (Local FilePrefix
prefix File
file) =
        FilePrefix -> File -> ImportType
Local FilePrefix
prefix (File -> File
forall path. Canonicalize path => path -> path
canonicalize File
file)

    canonicalize (Remote (URL {Maybe Text
Maybe (Expr Src Import)
Text
Scheme
File
headers :: URL -> Maybe (Expr Src Import)
query :: URL -> Maybe Text
path :: URL -> File
authority :: URL -> Text
scheme :: URL -> Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
path :: File
authority :: Text
scheme :: Scheme
..})) =
        URL -> ImportType
Remote (URL :: Scheme
-> Text -> File -> Maybe Text -> Maybe (Expr Src Import) -> URL
URL { path :: File
path = File -> File
forall path. Canonicalize path => path -> path
canonicalize File
path, headers :: Maybe (Expr Src Import)
headers = (Expr Src Import -> Expr Src Import)
-> Maybe (Expr Src Import) -> Maybe (Expr Src Import)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Import -> Import) -> Expr Src Import -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Import -> Import
forall path. Canonicalize path => path -> path
canonicalize) Maybe (Expr Src Import)
headers, Maybe Text
Text
Scheme
query :: Maybe Text
authority :: Text
scheme :: Scheme
query :: Maybe Text
authority :: Text
scheme :: Scheme
..})

    canonicalize (Env Text
name) =
        Text -> ImportType
Env Text
name

    canonicalize ImportType
Missing =
        ImportType
Missing

instance Canonicalize ImportHashed where
    canonicalize :: ImportHashed -> ImportHashed
canonicalize (ImportHashed Maybe SHA256Digest
hash ImportType
importType) =
        Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
hash (ImportType -> ImportType
forall path. Canonicalize path => path -> path
canonicalize ImportType
importType)

instance Canonicalize Import where
    canonicalize :: Import -> Import
canonicalize (Import ImportHashed
importHashed ImportMode
importMode) =
        ImportHashed -> ImportMode -> Import
Import (ImportHashed -> ImportHashed
forall path. Canonicalize path => path -> path
canonicalize ImportHashed
importHashed) ImportMode
importMode

-- | Exception thrown when an integrity check fails
data HashMismatch = HashMismatch
    { HashMismatch -> SHA256Digest
expectedHash :: Dhall.Crypto.SHA256Digest
    , HashMismatch -> SHA256Digest
actualHash   :: Dhall.Crypto.SHA256Digest
    } deriving (Typeable)

instance Exception HashMismatch

instance Show HashMismatch where
    show :: HashMismatch -> String
show HashMismatch{SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
actualHash :: HashMismatch -> SHA256Digest
expectedHash :: HashMismatch -> SHA256Digest
..} =
            String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
expectedHash SHA256Digest
actualHash

makeHashMismatchMessage :: Dhall.Crypto.SHA256Digest -> Dhall.Crypto.SHA256Digest -> String
makeHashMismatchMessage :: SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
expectedHash SHA256Digest
actualHash =
    String
"Import integrity check failed\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"Expected hash:\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
expectedHash String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"Actual hash:\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
actualHash String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

-- | Construct the file path corresponding to a local import. If the import is
--   _relative_ then the resulting path is also relative.
localToPath :: MonadIO io => FilePrefix -> File -> io FilePath
localToPath :: FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file_ = IO String -> io String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> io String) -> IO String -> io String
forall a b. (a -> b) -> a -> b
$ do
    let File {Text
Directory
file :: Text
directory :: Directory
file :: File -> Text
directory :: File -> Directory
..} = File
file_

    let Directory {[Text]
components :: Directory -> [Text]
components :: [Text]
..} = Directory
directory

    String
prefixPath <- case FilePrefix
prefix of
        FilePrefix
Home ->
            IO String
Directory.getHomeDirectory

        FilePrefix
Absolute ->
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"/"

        FilePrefix
Parent ->
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
".."

        FilePrefix
Here ->
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"."

    let cs :: [String]
cs = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (Text
file Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
components)

    let cons :: String -> ShowS
cons String
component String
dir = String
dir String -> ShowS
</> String
component

    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
cons String
prefixPath [String]
cs)

-- | Given a `Local` import construct the corresponding unhashed `Chained`
--   import (interpreting relative path as relative to the current directory).
chainedFromLocalHere :: FilePrefix -> File -> ImportMode -> Chained
chainedFromLocalHere :: FilePrefix -> File -> ImportMode -> Chained
chainedFromLocalHere FilePrefix
prefix File
file ImportMode
mode = Import -> Chained
Chained (Import -> Chained) -> Import -> Chained
forall a b. (a -> b) -> a -> b
$
     ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
forall a. Maybe a
Nothing (FilePrefix -> File -> ImportType
Local FilePrefix
prefix (File -> File
forall path. Canonicalize path => path -> path
canonicalize File
file))) ImportMode
mode

-- | Adjust the import mode of a chained import
chainedChangeMode :: ImportMode -> Chained -> Chained
chainedChangeMode :: ImportMode -> Chained -> Chained
chainedChangeMode ImportMode
mode (Chained (Import ImportHashed
importHashed ImportMode
_)) =
    Import -> Chained
Chained (ImportHashed -> ImportMode -> Import
Import ImportHashed
importHashed ImportMode
mode)

-- | Chain imports, also typecheck and normalize headers if applicable.
chainImport :: Chained -> Import -> StateT Status IO Chained
chainImport :: Chained -> Import -> StateT Status IO Chained
chainImport (Chained Import
parent) child :: Import
child@(Import importHashed :: ImportHashed
importHashed@(ImportHashed Maybe SHA256Digest
_ (Remote URL
url)) ImportMode
_) = do
    URL
url' <- URL -> StateT Status IO URL
normalizeHeadersIn URL
url
    let child' :: Import
child' = Import
child { importHashed :: ImportHashed
importHashed = ImportHashed
importHashed { importType :: ImportType
importType = URL -> ImportType
Remote URL
url' } }
    Chained -> StateT Status IO Chained
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (Import -> Import
forall path. Canonicalize path => path -> path
canonicalize (Import
parent Import -> Import -> Import
forall a. Semigroup a => a -> a -> a
<> Import
child')))

chainImport (Chained Import
parent) Import
child =
    Chained -> StateT Status IO Chained
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Chained
Chained (Import -> Import
forall path. Canonicalize path => path -> path
canonicalize (Import
parent Import -> Import -> Import
forall a. Semigroup a => a -> a -> a
<> Import
child)))

-- | Load an import, resulting in a fully resolved, type-checked and normalised
--   expression. @loadImport@ handles the \"hot\" cache in @Status@ and defers
--   to @loadImportWithSemanticCache@ for imports that aren't in the @Status@
--   cache already.
loadImport :: Chained -> StateT Status IO ImportSemantics
loadImport :: Chained -> StateT Status IO ImportSemantics
loadImport Chained
import_ = do
    Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get

    case Chained -> Map Chained ImportSemantics -> Maybe ImportSemantics
forall k v. Ord k => k -> Map k v -> Maybe v
Dhall.Map.lookup Chained
import_ Map Chained ImportSemantics
_cache of
        Just ImportSemantics
importSemantics -> ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics
importSemantics
        Maybe ImportSemantics
Nothing -> do
            ImportSemantics
importSemantics <- Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache Chained
import_
            LensLike' (Zooming IO ()) Status (Map Chained ImportSemantics)
-> StateT (Map Chained ImportSemantics) IO ()
-> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (Map Chained ImportSemantics)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (Map Chained ImportSemantics)
cache ((Map Chained ImportSemantics -> Map Chained ImportSemantics)
-> StateT (Map Chained ImportSemantics) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Chained
-> ImportSemantics
-> Map Chained ImportSemantics
-> Map Chained ImportSemantics
forall k v. Ord k => k -> v -> Map k v -> Map k v
Dhall.Map.insert Chained
import_ ImportSemantics
importSemantics))
            ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics
importSemantics

-- | Load an import from the 'semantic cache'. Defers to
--   @loadImportWithSemisemanticCache@ for imports that aren't frozen (and
--   therefore not cached semantically), as well as those that aren't cached yet.
loadImportWithSemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemanticCache
  import_ :: Chained
import_@(Chained (Import (ImportHashed Maybe SHA256Digest
Nothing ImportType
_) ImportMode
_)) =
    Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_

loadImportWithSemanticCache
  import_ :: Chained
import_@(Chained (Import ImportHashed
_ ImportMode
Location)) =
    Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_

loadImportWithSemanticCache
  import_ :: Chained
import_@(Chained (Import (ImportHashed (Just SHA256Digest
semanticHash) ImportType
_) ImportMode
_)) = do
    Status { [Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
.. } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
    Maybe ByteString
mCached <-
        case SemanticCacheMode
_semanticCacheMode of
            SemanticCacheMode
UseSemanticCache ->
                LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
-> StateT CacheWarning IO (Maybe ByteString)
-> StateT Status IO (Maybe ByteString)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> StateT CacheWarning IO (Maybe ByteString)
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
semanticHash)
            SemanticCacheMode
IgnoreSemanticCache ->
                Maybe ByteString -> StateT Status IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing

    case Maybe ByteString
mCached of
        Just ByteString
bytesStrict -> do
            let actualHash :: SHA256Digest
actualHash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytesStrict

            if SHA256Digest
semanticHash SHA256Digest -> SHA256Digest -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256Digest
actualHash
                then do
                    let bytesLazy :: ByteString
bytesLazy = ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bytesStrict

                    Expr Void Void
importSemantics <- case ByteString -> Either DecodingFailure (Expr Void Void)
forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
                        Left  DecodingFailure
err -> Imported DecodingFailure -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> DecodingFailure -> Imported DecodingFailure
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
                        Right Expr Void Void
e   -> Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
e

                    ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..})
                else do
                    String -> StateT Status IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning (String -> StateT Status IO ()) -> String -> StateT Status IO ()
forall a b. (a -> b) -> a -> b
$
                        SHA256Digest -> SHA256Digest -> String
makeHashMismatchMessage SHA256Digest
semanticHash SHA256Digest
actualHash
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"The interpreter will attempt to fix the cached import\n"
                    StateT Status IO ImportSemantics
fetch


        Maybe ByteString
Nothing -> StateT Status IO ImportSemantics
fetch
    where
        fetch :: StateT Status IO ImportSemantics
fetch = do
            ImportSemantics{ Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: ImportSemantics -> Expr Void Void
importSemantics } <- Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache Chained
import_

            let bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
Core.alphaNormalize Expr Void Void
importSemantics)

            let actualHash :: SHA256Digest
actualHash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytes

            let expectedHash :: SHA256Digest
expectedHash = SHA256Digest
semanticHash

            if SHA256Digest
actualHash SHA256Digest -> SHA256Digest -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256Digest
expectedHash
                then do
                    LensLike' (Zooming IO ()) Status CacheWarning
-> StateT CacheWarning IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
semanticHash ByteString
bytes)

                else do
                    Status{ NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get

                    Imported HashMismatch -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> HashMismatch -> Imported HashMismatch
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack HashMismatch :: SHA256Digest -> SHA256Digest -> HashMismatch
HashMismatch{SHA256Digest
expectedHash :: SHA256Digest
actualHash :: SHA256Digest
actualHash :: SHA256Digest
expectedHash :: SHA256Digest
..})

            ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics{Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..}



-- Fetch encoded normal form from "semantic cache"
fetchFromSemanticCache
    :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
    => Dhall.Crypto.SHA256Digest
    -> m (Maybe Data.ByteString.ByteString)
fetchFromSemanticCache :: SHA256Digest -> m (Maybe ByteString)
fetchFromSemanticCache SHA256Digest
expectedHash = MaybeT m ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m ByteString -> m (Maybe ByteString))
-> MaybeT m ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
    String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
 MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
expectedHash
    Bool
True <- IO Bool -> MaybeT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
    IO ByteString -> MaybeT m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
Data.ByteString.readFile String
cacheFile)

-- | Ensure that the given expression is present in the semantic cache. The
--   given expression should be alpha-beta-normal.
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
writeExpressionToSemanticCache :: Expr Void Void -> IO ()
writeExpressionToSemanticCache Expr Void Void
expression =
    -- Defaulting to not displaying the warning is for backwards compatibility
    -- with the old behavior
    StateT CacheWarning IO () -> CacheWarning -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes) CacheWarning
CacheWarned
  where
    bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression Expr Void Void
expression

    hash :: SHA256Digest
hash = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash ByteString
bytes

writeToSemanticCache
    :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
    => Dhall.Crypto.SHA256Digest
    -> Data.ByteString.ByteString
    -> m ()
writeToSemanticCache :: SHA256Digest -> ByteString -> m ()
writeToSemanticCache SHA256Digest
hash ByteString
bytes = do
    Maybe ()
_ <- MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
        String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
 MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall" SHA256Digest
hash
        IO () -> MaybeT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Check the "semi-semantic" disk cache, otherwise typecheck and normalise from
-- scratch.
loadImportWithSemisemanticCache
  :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache :: Chained -> StateT Status IO ImportSemantics
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
Code)) = do
    Text
text <- ImportType -> StateT Status IO Text
fetchFresh ImportType
importType
    Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get

    String
path <- case ImportType
importType of
        Local FilePrefix
prefix File
file -> IO String -> StateT Status IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Status IO String)
-> IO String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ do
            String
path <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
            String
absolutePath <- String -> IO String
Directory.makeAbsolute String
path
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
absolutePath
        Remote URL
url -> do
            let urlText :: Text
urlText = URL -> Text
forall a. Pretty a => a -> Text
Core.pretty (URL
url { headers :: Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
forall a. Maybe a
Nothing })
            String -> StateT Status IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
Text.unpack Text
urlText)
        Env Text
env -> String -> StateT Status IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT Status IO String)
-> String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
env
        ImportType
Missing -> MissingImports -> StateT Status IO String
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])

    let parser :: Parsec Void Text (Expr Src Import)
parser = Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import)
forall a. Parser a -> Parsec Void Text a
unParser (Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import))
-> Parser (Expr Src Import) -> Parsec Void Text (Expr Src Import)
forall a b. (a -> b) -> a -> b
$ do
            Parser ()
forall (m :: * -> *). TokenParsing m => m ()
Text.Parser.Token.whiteSpace
            Expr Src Import
r <- Parser (Expr Src Import)
Dhall.Parser.expr
            Parser ()
forall (m :: * -> *). Parsing m => m ()
Text.Parser.Combinators.eof
            Expr Src Import -> Parser (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
r

    Expr Src Import
parsedImport <- case Parsec Void Text (Expr Src Import)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (Expr Src Import)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Text.Megaparsec.parse Parsec Void Text (Expr Src Import)
parser String
path Text
text of
        Left  ParseErrorBundle Text Void
errInfo ->
            Imported ParseError -> StateT Status IO (Expr Src Import)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> ParseError -> Imported ParseError
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (ParseErrorBundle Text Void -> Text -> ParseError
ParseError ParseErrorBundle Text Void
errInfo Text
text))
        Right Expr Src Import
expr    -> Expr Src Import -> StateT Status IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
expr

    Expr Src Void
resolvedExpr <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
parsedImport  -- we load imports recursively here

    -- Check the semi-semantic cache. See
    -- https://github.com/dhall-lang/dhall-haskell/issues/1098 for the reasoning
    -- behind semi-semantic caching.
    let semisemanticHash :: SHA256Digest
semisemanticHash = Expr Void Void -> SHA256Digest
computeSemisemanticHash (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
resolvedExpr)

    Maybe ByteString
mCached <- LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
-> StateT CacheWarning IO (Maybe ByteString)
-> StateT Status IO (Maybe ByteString)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (Maybe ByteString)) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> StateT CacheWarning IO (Maybe ByteString)
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> m (Maybe ByteString)
fetchFromSemisemanticCache SHA256Digest
semisemanticHash)

    Expr Void Void
importSemantics <- case Maybe ByteString
mCached of
        Just ByteString
bytesStrict -> do
            let bytesLazy :: ByteString
bytesLazy = ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bytesStrict

            Expr Void Void
importSemantics <- case ByteString -> Either DecodingFailure (Expr Void Void)
forall s a.
Serialise (Expr s a) =>
ByteString -> Either DecodingFailure (Expr s a)
Dhall.Binary.decodeExpression ByteString
bytesLazy of
                Left DecodingFailure
err  -> Imported DecodingFailure -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> DecodingFailure -> Imported DecodingFailure
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack DecodingFailure
err)
                Right Expr Void Void
sem -> Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
sem

            Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
importSemantics

        Maybe ByteString
Nothing -> do
            let substitutedExpr :: Expr Src Void
substitutedExpr =
                  Expr Src Void -> Substitutions Src Void -> Expr Src Void
forall s a. Expr s a -> Substitutions s a -> Expr s a
Dhall.Substitution.substitute Expr Src Void
resolvedExpr Substitutions Src Void
_substitutions

            case Expr Src Import -> Expr Src Import
forall s a. Expr s a -> Expr s a
Core.shallowDenote Expr Src Import
parsedImport of
                -- If this import trivially wraps another import, we can skip
                -- the type-checking and normalization step as the transitive
                -- import was already type-checked and normalized
                Embed Import
_ ->
                    Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
substitutedExpr)

                Expr Src Import
_ -> do
                    case Context (Expr Src Void)
-> Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s.
Context (Expr s Void)
-> Expr s Void -> Either (TypeError s Void) (Expr s Void)
Dhall.TypeCheck.typeWith Context (Expr Src Void)
_startingContext Expr Src Void
substitutedExpr of
                        Left  TypeError Src Void
err -> Imported (TypeError Src Void) -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> TypeError Src Void -> Imported (TypeError Src Void)
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack TypeError Src Void
err)
                        Right Expr Src Void
_   -> () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    let betaNormal :: Expr t Void
betaNormal =
                            Maybe (ReifiedNormalizer Void) -> Expr Src Void -> Expr t Void
forall a s t.
Eq a =>
Maybe (ReifiedNormalizer a) -> Expr s a -> Expr t a
Core.normalizeWith Maybe (ReifiedNormalizer Void)
_normalizer Expr Src Void
substitutedExpr

                    let bytes :: ByteString
bytes = Expr Void Void -> ByteString
encodeExpression Expr Void Void
forall t. Expr t Void
betaNormal

                    LensLike' (Zooming IO ()) Status CacheWarning
-> StateT CacheWarning IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status CacheWarning
forall (f :: * -> *). Functor f => LensLike' f Status CacheWarning
cacheWarning (SHA256Digest -> ByteString -> StateT CacheWarning IO ()
forall (m :: * -> *).
(MonadState CacheWarning m, MonadCatch m, MonadIO m) =>
SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes)

                    Expr Void Void -> StateT Status IO (Expr Void Void)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Void Void
forall t. Expr t Void
betaNormal

    ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: Expr Void Void
..})

-- `as Text` imports aren't cached since they are well-typed and normal by
-- construction
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
RawText)) = do
    Text
text <- ImportType -> StateT Status IO Text
fetchFresh ImportType
importType

    -- importSemantics is alpha-beta-normal by construction!
    let importSemantics :: Expr s a
importSemantics = Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] Text
text)
    ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
forall s a. Expr s a
importSemantics :: forall s a. Expr s a
importSemantics :: Expr Void Void
..})

-- `as Location` imports aren't cached since they are well-typed and normal by
-- construction
loadImportWithSemisemanticCache (Chained (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
Location)) = do
    let locationType :: Expr s a
locationType = Map Text (Maybe (Expr s a)) -> Expr s a
forall s a. Map Text (Maybe (Expr s a)) -> Expr s a
Union (Map Text (Maybe (Expr s a)) -> Expr s a)
-> Map Text (Maybe (Expr s a)) -> Expr s a
forall a b. (a -> b) -> a -> b
$ [(Text, Maybe (Expr s a))] -> Map Text (Maybe (Expr s a))
forall k v. Ord k => [(k, v)] -> Map k v
Dhall.Map.fromList
            [ (Text
"Environment", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
            , (Text
"Remote", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
            , (Text
"Local", Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
forall s a. Expr s a
Text)
            , (Text
"Missing", Maybe (Expr s a)
forall a. Maybe a
Nothing)
            ]

    -- importSemantics is alpha-beta-normal by construction!
    let importSemantics :: Expr s a
importSemantics = case ImportType
importType of
            ImportType
Missing -> Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection  Text
"Missing"
            local :: ImportType
local@(Local FilePrefix
_ File
_) ->
                Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Local")
                  (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (ImportType -> Text
forall a. Pretty a => a -> Text
Core.pretty ImportType
local)))
            remote_ :: ImportType
remote_@(Remote URL
_) ->
                Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Remote")
                  (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (ImportType -> Text
forall a. Pretty a => a -> Text
Core.pretty ImportType
remote_)))
            Env Text
env ->
                Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
App (Expr s a -> FieldSelection s -> Expr s a
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr s a
forall s a. Expr s a
locationType (FieldSelection s -> Expr s a) -> FieldSelection s -> Expr s a
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection s
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
"Environment")
                  (Chunks s a -> Expr s a
forall s a. Chunks s a -> Expr s a
TextLit ([(Text, Expr s a)] -> Text -> Chunks s a
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (Text -> Text
forall a. Pretty a => a -> Text
Core.pretty Text
env)))

    ImportSemantics -> StateT Status IO ImportSemantics
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportSemantics :: Expr Void Void -> ImportSemantics
ImportSemantics {Expr Void Void
forall s a. Expr s a
importSemantics :: forall s a. Expr s a
importSemantics :: Expr Void Void
..})

-- The semi-semantic hash of an expression is computed from the fully resolved
-- AST (without normalising or type-checking it first). See
-- https://github.com/dhall-lang/dhall-haskell/issues/1098 for further
-- discussion.
computeSemisemanticHash :: Expr Void Void -> Dhall.Crypto.SHA256Digest
computeSemisemanticHash :: Expr Void Void -> SHA256Digest
computeSemisemanticHash Expr Void Void
resolvedExpr = Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
resolvedExpr

-- Fetch encoded normal form from "semi-semantic cache"
fetchFromSemisemanticCache
    :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
    => Dhall.Crypto.SHA256Digest
    -> m (Maybe Data.ByteString.ByteString)
fetchFromSemisemanticCache :: SHA256Digest -> m (Maybe ByteString)
fetchFromSemisemanticCache SHA256Digest
semisemanticHash = MaybeT m ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m ByteString -> m (Maybe ByteString))
-> MaybeT m ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
    String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
 MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
    Bool
True <- IO Bool -> MaybeT m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
cacheFile)
    IO ByteString -> MaybeT m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
Data.ByteString.readFile String
cacheFile)

writeToSemisemanticCache
    :: (MonadState CacheWarning m, MonadCatch m, MonadIO m)
    => Dhall.Crypto.SHA256Digest
    -> Data.ByteString.ByteString
    -> m ()
writeToSemisemanticCache :: SHA256Digest -> ByteString -> m ()
writeToSemisemanticCache SHA256Digest
semisemanticHash ByteString
bytes = do
    Maybe ()
_ <- MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
        String
cacheFile <- String -> SHA256Digest -> MaybeT m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
 MonadIO m) =>
String -> SHA256Digest -> m String
getCacheFile String
"dhall-haskell" SHA256Digest
semisemanticHash
        IO () -> MaybeT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
AtomicWrite.Binary.atomicWriteFile String
cacheFile ByteString
bytes)
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Fetch source code directly from disk/network
fetchFresh :: ImportType -> StateT Status IO Text
fetchFresh :: ImportType -> StateT Status IO Text
fetchFresh (Local FilePrefix
prefix File
file) = do
    Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
    String
path <- IO String -> StateT Status IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Status IO String)
-> IO String -> StateT Status IO String
forall a b. (a -> b) -> a -> b
$ FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
prefix File
file
    Bool
exists <- IO Bool -> StateT Status IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT Status IO Bool)
-> IO Bool -> StateT Status IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Directory.doesFileExist String
path
    if Bool
exists
        then IO Text -> StateT Status IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> StateT Status IO Text)
-> IO Text -> StateT Status IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
Data.Text.IO.readFile String
path
        else Imported MissingFile -> StateT Status IO Text
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> MissingFile -> Imported MissingFile
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (String -> MissingFile
MissingFile String
path))

fetchFresh (Remote URL
url) = do
    Status { URL -> StateT Status IO Text
_remote :: URL -> StateT Status IO Text
_remote :: Status -> URL -> StateT Status IO Text
_remote } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
    URL -> StateT Status IO Text
_remote URL
url

fetchFresh (Env Text
env) = do
    Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
    Maybe String
x <- IO (Maybe String) -> StateT Status IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> StateT Status IO (Maybe String))
-> IO (Maybe String) -> StateT Status IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
System.Environment.lookupEnv (Text -> String
Text.unpack Text
env)
    case Maybe String
x of
        Just String
string ->
            Text -> StateT Status IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
Text.pack String
string)
        Maybe String
Nothing ->
                Imported MissingEnvironmentVariable -> StateT Status IO Text
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> MissingEnvironmentVariable
-> Imported MissingEnvironmentVariable
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Text -> MissingEnvironmentVariable
MissingEnvironmentVariable Text
env))

fetchFresh ImportType
Missing = MissingImports -> StateT Status IO Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([SomeException] -> MissingImports
MissingImports [])

-- | Fetch the text contents of a URL
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 (Core.pretty url)
    Status { _stack } <- State.get
    throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders))
#else
fetchRemote :: URL -> StateT Status IO Text
fetchRemote URL
url = do
    LensLike' (Zooming IO ()) Status (URL -> StateT Status IO Text)
-> StateT (URL -> StateT Status IO Text) IO ()
-> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (URL -> StateT Status IO Text)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
remote ((URL -> StateT Status IO Text)
-> StateT (URL -> StateT Status IO Text) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put URL -> StateT Status IO Text
fetchFromHTTP)
    URL -> StateT Status IO Text
fetchFromHTTP URL
url
  where
    fetchFromHTTP :: URL -> StateT Status IO Data.Text.Text
    fetchFromHTTP :: URL -> StateT Status IO Text
fetchFromHTTP (url' :: URL
url'@URL { headers :: URL -> Maybe (Expr Src Import)
headers = Maybe (Expr Src Import)
maybeHeadersExpression }) = do
        let maybeHeaders :: Maybe [HTTPHeader]
maybeHeaders = (Expr Src Import -> [HTTPHeader])
-> Maybe (Expr Src Import) -> Maybe [HTTPHeader]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Src Import -> [HTTPHeader]
forall s a. Expr s a -> [HTTPHeader]
toHeaders Maybe (Expr Src Import)
maybeHeadersExpression
        URL -> Maybe [HTTPHeader] -> StateT Status IO Text
fetchFromHttpUrl URL
url' Maybe [HTTPHeader]
maybeHeaders
#endif

getCacheFile
    :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
    => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath
getCacheFile :: String -> SHA256Digest -> m String
getCacheFile String
cacheName SHA256Digest
hash = do
    String
cacheDirectory <- String -> m String
forall (m :: * -> *).
(MonadCatch m, Alternative m, MonadState CacheWarning m,
 MonadIO m) =>
String -> m String
getOrCreateCacheDirectory String
cacheName

    let cacheFile :: String
cacheFile = String
cacheDirectory String -> ShowS
</> (String
"1220" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SHA256Digest -> String
forall a. Show a => a -> String
show SHA256Digest
hash)

    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
cacheFile

getOrCreateCacheDirectory
    :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m)
    => FilePath -> m FilePath
getOrCreateCacheDirectory :: String -> m String
getOrCreateCacheDirectory String
cacheName = do
    let warn :: String -> m b
warn String
message = do
            CacheWarning
cacheWarningStatus <- m CacheWarning
forall s (m :: * -> *). MonadState s m => m s
State.get

            case CacheWarning
cacheWarningStatus of
                CacheWarning
CacheWarned    -> String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
printWarning String
message
                CacheWarning
CacheNotWarned -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            CacheWarning -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned

            m b
forall (f :: * -> *) a. Alternative f => f a
empty

    let handler :: String -> String -> IOException -> m b
handler String
action String
dir (IOException
ioex :: IOException) = do
            let ioExMsg :: String
ioExMsg =
                     String
"When trying to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
action String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... the following exception was thrown:\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a. Show a => a -> String
show IOException
ioex String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

            String -> m b
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
ioExMsg

    let setPermissions :: String -> m ()
setPermissions String
dir = do
            let private :: Permissions
private = Permissions -> Permissions
transform Permissions
Directory.emptyPermissions
                    where
                        transform :: Permissions -> Permissions
transform =
                            Bool -> Permissions -> Permissions
Directory.setOwnerReadable   Bool
True
                          (Permissions -> Permissions)
-> (Permissions -> Permissions) -> Permissions -> Permissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerWritable   Bool
True
                          (Permissions -> Permissions)
-> (Permissions -> Permissions) -> Permissions -> Permissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Permissions -> Permissions
Directory.setOwnerSearchable Bool
True

            m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> Permissions -> IO ()
Directory.setPermissions String
dir Permissions
private))
                (String -> String -> IOException -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"correct the permissions for" String
dir)

    let assertPermissions :: String -> m ()
assertPermissions String
dir = do
            let accessible :: Permissions -> Bool
accessible Permissions
path =
                    Permissions -> Bool
Directory.readable   Permissions
path
                 Bool -> Bool -> Bool
&& Permissions -> Bool
Directory.writable   Permissions
path
                 Bool -> Bool -> Bool
&& Permissions -> Bool
Directory.searchable Permissions
path

            Permissions
permissions <-
                m Permissions -> (IOException -> m Permissions) -> m Permissions
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Permissions -> m Permissions
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Permissions
Directory.getPermissions String
dir))
                      (String -> String -> IOException -> m Permissions
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"get permissions of" String
dir)

            if Permissions -> Bool
accessible Permissions
permissions
                then
                    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else do
                    let render :: (Permissions -> Bool) -> p
render Permissions -> Bool
f = if Permissions -> Bool
f Permissions
permissions then p
"✓" else p
"✗"
                    let message :: String
message =
                             String
"The directory:\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... does not give you permission to read, write, or search files.\n\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"The directory's current permissions are:\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.readable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" readable\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.writable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" writable\n"
                          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"• " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Permissions -> Bool) -> String
forall p. IsString p => (Permissions -> Bool) -> p
render Permissions -> Bool
Directory.searchable String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" searchable\n"

                    String -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message

    let existsDirectory :: String -> m Bool
existsDirectory String
dir =
            m Bool -> (IOException -> m Bool) -> m Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesDirectoryExist String
dir))
                  (String -> String -> IOException -> m Bool
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"check the existence of" String
dir)

    let existsFile :: String -> m Bool
existsFile String
path =
            m Bool -> (IOException -> m Bool) -> m Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
Directory.doesFileExist String
path))
                  (String -> String -> IOException -> m Bool
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"check the existence of" String
path)

    let createDirectory :: String -> m ()
createDirectory String
dir =
            m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
Directory.createDirectory String
dir))
                  (String -> String -> IOException -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> String -> IOException -> m b
handler String
"create" String
dir)

    let assertDirectory :: String -> m ()
assertDirectory String
dir = do
            Bool
existsDir <- String -> m Bool
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m Bool
existsDirectory String
dir

            if Bool
existsDir
                then
                    String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m ()
assertPermissions String
dir

                else do
                    Bool
existsFile' <- String -> m Bool
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m Bool
existsFile String
dir

                    if Bool
existsFile'
                        then do
                            let message :: String
message =
                                     String
"The given path:\n"
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dir String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"... already exists but is not a directory.\n"

                            String -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message

                        else do
                            String -> m ()
assertDirectory (ShowS
FilePath.takeDirectory String
dir)

                            String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m ()
createDirectory String
dir

                            String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m ()
setPermissions String
dir

    String
cacheBaseDirectory <- m String
forall (m :: * -> *).
(MonadState CacheWarning m, Alternative m, MonadIO m) =>
m String
getCacheBaseDirectory

    let directory :: String
directory = String
cacheBaseDirectory String -> ShowS
</> String
cacheName

    let message :: String
message =
             String
"Could not get or create the default cache directory:\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"↳ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
directory String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"You can enable caching by creating it if needed and setting read,\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"write and search permissions on it or providing another cache base\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"directory by setting the $XDG_CACHE_HOME environment variable.\n"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

    String -> m ()
forall (m :: * -> *).
(MonadCatch m, MonadIO m, MonadState CacheWarning m,
 Alternative m) =>
String -> m ()
assertDirectory String
directory m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m ()
forall (m :: * -> *) b.
(MonadState CacheWarning m, MonadIO m, Alternative m) =>
String -> m b
warn String
message

    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
directory

getCacheBaseDirectory
    :: (MonadState CacheWarning m, Alternative m, MonadIO m) => m FilePath
getCacheBaseDirectory :: m String
getCacheBaseDirectory = m String
alternative₀ m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
alternative₁ m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
forall b. m b
alternative₂
  where
    alternative₀ :: m String
alternative₀ = do
        Maybe String
maybeXDGCacheHome <-
          IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"XDG_CACHE_HOME")

        case Maybe String
maybeXDGCacheHome of
            Just String
xdgCacheHome -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xdgCacheHome
            Maybe String
Nothing           -> m String
forall (f :: * -> *) a. Alternative f => f a
empty

    alternative₁ :: m String
alternative₁
        | Bool
isWindows = do
            Maybe String
maybeLocalAppDirectory <-
              IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"LOCALAPPDATA")

            case Maybe String
maybeLocalAppDirectory of
                Just String
localAppDirectory -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
localAppDirectory
                Maybe String
Nothing                -> m String
forall (f :: * -> *) a. Alternative f => f a
empty

        | Bool
otherwise = do
            Maybe String
maybeHomeDirectory <-
              IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
System.Environment.lookupEnv String
"HOME")

            case Maybe String
maybeHomeDirectory of
                Just String
homeDirectory -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
homeDirectory String -> ShowS
</> String
".cache")
                Maybe String
Nothing            -> m String
forall (f :: * -> *) a. Alternative f => f a
empty

        where isWindows :: Bool
isWindows = String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32"

    alternative₂ :: m b
alternative₂ = do
        CacheWarning
cacheWarningStatus <- m CacheWarning
forall s (m :: * -> *). MonadState s m => m s
State.get

        let message :: String
message =
                String
"\n"
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Could not locate a cache base directory from the environment.\n"
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"You can provide a cache base directory by pointing the $XDG_CACHE_HOME\n"
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"environment variable to a directory with read and write permissions.\n"

        case CacheWarning
cacheWarningStatus of
            CacheWarning
CacheNotWarned ->
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr String
message)
            CacheWarning
CacheWarned ->
                () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        CacheWarning -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put CacheWarning
CacheWarned

        m b
forall (f :: * -> *) a. Alternative f => f a
empty

-- If the URL contains headers typecheck them and replace them with their normal
-- forms.
normalizeHeadersIn :: URL -> StateT Status IO URL
normalizeHeadersIn :: URL -> StateT Status IO URL
normalizeHeadersIn url :: URL
url@URL { headers :: URL -> Maybe (Expr Src Import)
headers = Just Expr Src Import
headersExpression } = do
    Status { NonEmpty Chained
_stack :: NonEmpty Chained
_stack :: Status -> NonEmpty Chained
_stack } <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get
    Expr Src Void
loadedExpr <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
headersExpression
    let handler :: SomeException -> m a
handler (SomeException
e :: SomeException) = Imported SomeException -> m a
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> SomeException -> Imported SomeException
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack SomeException
e)
    Expr Src Void
normalized <- IO (Expr Src Void) -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Expr Src Void) -> StateT Status IO (Expr Src Void))
-> IO (Expr Src Void) -> StateT Status IO (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO (Expr Src Void))
-> IO (Expr Src Void) -> IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO (Expr Src Void)
forall (m :: * -> *) a. MonadCatch m => SomeException -> m a
handler (Expr Src Void -> IO (Expr Src Void)
normalizeHeaders Expr Src Void
loadedExpr)
    URL -> StateT Status IO URL
forall (m :: * -> *) a. Monad m => a -> m a
return URL
url { headers :: Maybe (Expr Src Import)
headers = Expr Src Import -> Maybe (Expr Src Import)
forall a. a -> Maybe a
Just ((Void -> Import) -> Expr Src Void -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
absurd Expr Src Void
normalized) }

normalizeHeadersIn URL
url = URL -> StateT Status IO URL
forall (m :: * -> *) a. Monad m => a -> m a
return URL
url

-- | Empty origin headers used for remote contexts
--   (and fallback when nothing is set in env or config file)
emptyOriginHeaders :: Expr Src Import
emptyOriginHeaders :: Expr Src Import
emptyOriginHeaders = Maybe (Expr Src Import) -> Seq (Expr Src Import) -> Expr Src Import
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
ListLit (Expr Src Import -> Maybe (Expr Src Import)
forall a. a -> Maybe a
Just ((Void -> Import) -> Expr Src Void -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
absurd Expr Src Void
originHeadersTypeExpr)) Seq (Expr Src Import)
forall a. Monoid a => a
mempty

-- | A fake Src to annotate headers expressions with.
--   We need to wrap headers expressions in a Note for nice error reporting,
--   and because ImportAlt handling only catches SourcedExceptions
headersSrc :: Src
headersSrc :: Src
headersSrc = Src :: SourcePos -> SourcePos -> Text -> Src
Src {
        srcStart :: SourcePos
srcStart = SourcePos :: String -> Pos -> Pos -> SourcePos
SourcePos {
            sourceName :: String
sourceName = String
fakeSrcName,
            sourceLine :: Pos
sourceLine = Int -> Pos
mkPos Int
1,
            sourceColumn :: Pos
sourceColumn = Int -> Pos
mkPos Int
1
        },
        srcEnd :: SourcePos
srcEnd = SourcePos :: String -> Pos -> Pos -> SourcePos
SourcePos {
            sourceName :: String
sourceName = String
fakeSrcName,
            sourceLine :: Pos
sourceLine = Int -> Pos
mkPos Int
1,
            sourceColumn :: Pos
sourceColumn = Int -> Pos
mkPos (Text -> Int
Text.length Text
fakeSrcText)
        },
        srcText :: Text
srcText = Text
fakeSrcText
    }
  where
    fakeSrcText :: Text
fakeSrcText = Text
"«Origin Header Configuration»"
    fakeSrcName :: String
fakeSrcName = String
"[builtin]"

-- | Load headers only from the environment (used in tests)
envOriginHeaders :: Expr Src Import
envOriginHeaders :: Expr Src Import
envOriginHeaders = Src -> Expr Src Import -> Expr Src Import
forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (Import -> Expr Src Import
forall s a. a -> Expr s a
Embed (ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
forall a. Maybe a
Nothing (Text -> ImportType
Env Text
"DHALL_HEADERS")) ImportMode
Code))

-- | Load headers in env, falling back to config file
defaultOriginHeaders :: IO (Expr Src Import)
#ifndef WITH_HTTP
defaultOriginHeaders = return emptyOriginHeaders
#else
defaultOriginHeaders :: IO (Expr Src Import)
defaultOriginHeaders = do
    Expr Src Import
fromFile <- IO (Expr Src Import)
originHeadersFileExpr
    Expr Src Import -> IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Src -> Expr Src Import -> Expr Src Import
forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (Expr Src Import -> Expr Src Import -> Expr Src Import
forall s a. Expr s a -> Expr s a -> Expr s a
ImportAlt Expr Src Import
envOriginHeaders (Src -> Expr Src Import -> Expr Src Import
forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc Expr Src Import
fromFile)))
#endif

-- | Given a headers expression, return an origin headers loader
originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader IO (Expr Src Import)
headersExpr = do

    -- Load the headers using the parent stack, which should always be a local
    -- import (we only load headers for the first remote import)

    Status
status <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get

    let parentStack :: NonEmpty Chained
parentStack = NonEmpty Chained -> Maybe (NonEmpty Chained) -> NonEmpty Chained
forall a. a -> Maybe a -> a
fromMaybe NonEmpty Chained
forall b. b
abortEmptyStack ([Chained] -> Maybe (NonEmpty Chained)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (NonEmpty Chained -> [Chained]
forall a. NonEmpty a -> [a]
NonEmpty.tail (Status -> NonEmpty Chained
_stack Status
status)))

    let headerLoadStatus :: Status
headerLoadStatus = Status
status { _stack :: NonEmpty Chained
_stack = NonEmpty Chained
parentStack }

    (OriginHeaders
headers, Status
_) <- IO (OriginHeaders, Status)
-> StateT Status IO (OriginHeaders, Status)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (StateT Status IO OriginHeaders
-> Status -> IO (OriginHeaders, Status)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT StateT Status IO OriginHeaders
doLoad Status
headerLoadStatus)

    -- return cached headers next time
    ()
_ <- (Status -> Status) -> StateT Status IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\Status
state -> Status
state { _loadOriginHeaders :: StateT Status IO OriginHeaders
_loadOriginHeaders = OriginHeaders -> StateT Status IO OriginHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return OriginHeaders
headers })

    OriginHeaders -> StateT Status IO OriginHeaders
forall (m :: * -> *) a. Monad m => a -> m a
return OriginHeaders
headers
  where
    abortEmptyStack :: b
abortEmptyStack = Text -> forall b. b
Core.internalError Text
"Origin headers loaded with an empty stack"

    doLoad :: StateT Status IO OriginHeaders
doLoad = do
        Expr Src Import
partialExpr <- IO (Expr Src Import) -> StateT Status IO (Expr Src Import)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Expr Src Import)
headersExpr
        Expr Src Void
loaded <- Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith (Src -> Expr Src Import -> Expr Src Import
forall s a. s -> Expr s a -> Expr s a
Note Src
headersSrc (Expr Src Import -> Expr Src Import -> Expr Src Import
forall s a. Expr s a -> Expr s a -> Expr s a
ImportAlt Expr Src Import
partialExpr Expr Src Import
emptyOriginHeaders))
        IO OriginHeaders -> StateT Status IO OriginHeaders
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Expr Src Void -> IO OriginHeaders
toOriginHeaders Expr Src Void
loaded)

-- | Default starting `Status`, importing relative to the given directory.
emptyStatus :: FilePath -> Status
emptyStatus :: String -> Status
emptyStatus = IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
defaultNewManager IO (Expr Src Import)
defaultOriginHeaders

-- | See 'emptyStatus'
emptyStatusWithManager
    :: IO Manager
    -> FilePath
    -> Status
emptyStatusWithManager :: IO Manager -> String -> Status
emptyStatusWithManager IO Manager
newManager = IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
defaultOriginHeaders

-- | See 'emptyStatus'.
makeEmptyStatus
    :: IO Manager
    -> IO (Expr Src Import)
    -> FilePath
    -> Status
makeEmptyStatus :: IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
headersExpr String
rootDirectory =
    IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> Import
-> Status
emptyStatusWith IO Manager
newManager (IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader IO (Expr Src Import)
headersExpr) URL -> StateT Status IO Text
fetchRemote Import
rootImport
  where
    prefix :: FilePrefix
prefix = if String -> Bool
FilePath.isRelative String
rootDirectory
      then FilePrefix
Here
      else FilePrefix
Absolute

    pathComponents :: [Text]
pathComponents =
        (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack ([String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
FilePath.splitDirectories String
rootDirectory))

    directoryAsFile :: File
directoryAsFile = Directory -> Text -> File
File ([Text] -> Directory
Directory [Text]
pathComponents) Text
"."

    rootImport :: Import
rootImport = Import :: ImportHashed -> ImportMode -> Import
Import
      { importHashed :: ImportHashed
importHashed = ImportHashed :: Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed
        { hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
        , importType :: ImportType
importType = FilePrefix -> File -> ImportType
Local FilePrefix
prefix File
directoryAsFile
        }
      , importMode :: ImportMode
importMode = ImportMode
Code
      }

{-| Default `Status` appropriate for a server interpreting Dhall code

    Using this `Status` ensures that interpreted Dhall code cannot access
    server-local resources (like files or environment variables)
-}
remoteStatus
    :: URL
    -- ^ Public address of the server
    -> Status
remoteStatus :: URL -> Status
remoteStatus = IO Manager -> URL -> Status
remoteStatusWithManager IO Manager
defaultNewManager

-- | See `remoteStatus`
remoteStatusWithManager :: IO Manager -> URL -> Status
remoteStatusWithManager :: IO Manager -> URL -> Status
remoteStatusWithManager IO Manager
newManager URL
url =
    IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> Import
-> Status
emptyStatusWith IO Manager
newManager (IO (Expr Src Import) -> StateT Status IO OriginHeaders
originHeadersLoader (Expr Src Import -> IO (Expr Src Import)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Src Import
emptyOriginHeaders)) URL -> StateT Status IO Text
fetchRemote Import
rootImport
  where
    rootImport :: Import
rootImport = Import :: ImportHashed -> ImportMode -> Import
Import
      { importHashed :: ImportHashed
importHashed = ImportHashed :: Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed
        { hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
        , importType :: ImportType
importType = URL -> ImportType
Remote URL
url
        }
      , importMode :: ImportMode
importMode = ImportMode
Code
      }

{-| Generalized version of `load`

    You can configure the desired behavior through the initial `Status` that you
    supply
-}
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expr₀ = case Expr Src Import
expr₀ of
  Embed Import
import₀ -> do
    Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
StateT Status IO OriginHeaders
Context (Expr Src Void)
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_manager :: Status -> Maybe Manager
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
..} <- StateT Status IO Status
forall s (m :: * -> *). MonadState s m => m s
State.get

    let parent :: Chained
parent = NonEmpty Chained -> Chained
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Chained
_stack

    Chained
child <- Chained -> Import -> StateT Status IO Chained
chainImport Chained
parent Import
import₀

    let local :: Chained -> Bool
local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Remote  {})) ImportMode
_)) = Bool
False
        local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Local   {})) ImportMode
_)) = Bool
True
        local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Env     {})) ImportMode
_)) = Bool
True
        local (Chained (Import (ImportHashed Maybe SHA256Digest
_ (Missing {})) ImportMode
_)) = Bool
False

    let referentiallySane :: Bool
referentiallySane = Bool -> Bool
not (Chained -> Bool
local Chained
child) Bool -> Bool -> Bool
|| Chained -> Bool
local Chained
parent

    if Import -> ImportMode
importMode Import
import₀ ImportMode -> ImportMode -> Bool
forall a. Eq a => a -> a -> Bool
== ImportMode
Location Bool -> Bool -> Bool
|| Bool
referentiallySane
        then () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else Imported ReferentiallyOpaque -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained
-> ReferentiallyOpaque -> Imported ReferentiallyOpaque
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> ReferentiallyOpaque
ReferentiallyOpaque Import
import₀))

    let _stack' :: NonEmpty Chained
_stack' = Chained -> NonEmpty Chained -> NonEmpty Chained
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack

    if Chained
child Chained -> NonEmpty Chained -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Chained
_stack
        then Imported Cycle -> StateT Status IO ()
forall (m :: * -> *) e a. (MonadCatch m, Exception e) => e -> m a
throwMissingImport (NonEmpty Chained -> Cycle -> Imported Cycle
forall e. NonEmpty Chained -> e -> Imported e
Imported NonEmpty Chained
_stack (Import -> Cycle
Cycle Import
import₀))
        else () -> StateT Status IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    LensLike' (Zooming IO ()) Status [Depends]
-> StateT [Depends] IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status [Depends]
forall (f :: * -> *). Functor f => LensLike' f Status [Depends]
graph (StateT [Depends] IO () -> StateT Status IO ())
-> (([Depends] -> [Depends]) -> StateT [Depends] IO ())
-> ([Depends] -> [Depends])
-> StateT Status IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Depends] -> [Depends]) -> StateT [Depends] IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (([Depends] -> [Depends]) -> StateT Status IO ())
-> ([Depends] -> [Depends]) -> StateT Status IO ()
forall a b. (a -> b) -> a -> b
$
        -- Add the edge `parent -> child` to the import graph
        \[Depends]
edges -> Chained -> Chained -> Depends
Depends Chained
parent Chained
child Depends -> [Depends] -> [Depends]
forall a. a -> [a] -> [a]
: [Depends]
edges

    let stackWithChild :: NonEmpty Chained
stackWithChild = Chained -> NonEmpty Chained -> NonEmpty Chained
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Chained
child NonEmpty Chained
_stack

    LensLike' (Zooming IO ()) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (NonEmpty Chained -> StateT (NonEmpty Chained) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put NonEmpty Chained
stackWithChild)
    ImportSemantics {Expr Void Void
importSemantics :: Expr Void Void
importSemantics :: ImportSemantics -> Expr Void Void
..} <- Chained -> StateT Status IO ImportSemantics
loadImport Chained
child
    LensLike' (Zooming IO ()) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO () -> StateT Status IO ()
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO ()) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack (NonEmpty Chained -> StateT (NonEmpty Chained) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put NonEmpty Chained
_stack)

    Expr Src Void -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Void Void -> Expr Src Void
forall a s. Expr Void a -> Expr s a
Core.renote Expr Void Void
importSemantics)

  ImportAlt Expr Src Import
a Expr Src Import
b -> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
a StateT Status IO (Expr Src Void)
-> (SourcedException MissingImports
    -> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SourcedException MissingImports -> StateT Status IO (Expr Src Void)
handler₀
    where
      is :: forall e . Exception e => SomeException -> Bool
      is :: SomeException -> Bool
is SomeException
exception = Maybe e -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
Exception.fromException @e SomeException
exception)

      isNotResolutionError :: SomeException -> Bool
isNotResolutionError SomeException
exception =
              SomeException -> Bool
forall e. Exception e => SomeException -> Bool
is @(Imported (TypeError Src Void)) SomeException
exception
          Bool -> Bool -> Bool
||  SomeException -> Bool
forall e. Exception e => SomeException -> Bool
is @(Imported  Cycle              ) SomeException
exception
          Bool -> Bool -> Bool
||  SomeException -> Bool
forall e. Exception e => SomeException -> Bool
is @(Imported  HashMismatch       ) SomeException
exception
          Bool -> Bool -> Bool
||  SomeException -> Bool
forall e. Exception e => SomeException -> Bool
is @(Imported  ParseError         ) SomeException
exception

      handler₀ :: SourcedException MissingImports -> StateT Status IO (Expr Src Void)
handler₀ exception₀ :: SourcedException MissingImports
exception₀@(SourcedException (Src SourcePos
begin SourcePos
_ Text
text₀) (MissingImports [SomeException]
es₀))
          | (SomeException -> Bool) -> [SomeException] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SomeException -> Bool
isNotResolutionError [SomeException]
es₀ =
              SourcedException MissingImports -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SourcedException MissingImports
exception₀
          | Bool
otherwise = do
              Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b StateT Status IO (Expr Src Void)
-> (SourcedException MissingImports
    -> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SourcedException MissingImports -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a.
MonadThrow m =>
SourcedException MissingImports -> m a
handler₁
        where
          handler₁ :: SourcedException MissingImports -> m a
handler₁ exception₁ :: SourcedException MissingImports
exception₁@(SourcedException (Src SourcePos
_ SourcePos
end Text
text₁) (MissingImports [SomeException]
es₁))
              | (SomeException -> Bool) -> [SomeException] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SomeException -> Bool
isNotResolutionError [SomeException]
es₁ =
                  SourcedException MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SourcedException MissingImports
exception₁
              | Bool
otherwise =
                  -- Fix the source span for the error message to encompass both
                  -- alternatives, since both are equally to blame for the
                  -- failure if neither succeeds.
                  SourcedException MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Src -> MissingImports -> SourcedException MissingImports
forall e. Src -> e -> SourcedException e
SourcedException (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
begin SourcePos
end Text
text₂) ([SomeException] -> MissingImports
MissingImports ([SomeException]
es₀ [SomeException] -> [SomeException] -> [SomeException]
forall a. [a] -> [a] -> [a]
++ [SomeException]
es₁)))
            where
              text₂ :: Text
text₂ = Text
text₀ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ? " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text₁

  Note Src
a Expr Src Import
b             -> do
      let handler :: MissingImports -> m a
handler MissingImports
e = SourcedException MissingImports -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Src -> MissingImports -> SourcedException MissingImports
forall e. Src -> e -> SourcedException e
SourcedException Src
a (MissingImports
e :: MissingImports))

      (Src -> Expr Src Void -> Expr Src Void
forall s a. s -> Expr s a -> Expr s a
Note (Src -> Expr Src Void -> Expr Src Void)
-> StateT Status IO Src
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Src -> StateT Status IO Src
forall (f :: * -> *) a. Applicative f => a -> f a
pure Src
a StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b) StateT Status IO (Expr Src Void)
-> (MissingImports -> StateT Status IO (Expr Src Void))
-> StateT Status IO (Expr Src Void)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` MissingImports -> StateT Status IO (Expr Src Void)
forall (m :: * -> *) a. MonadThrow m => MissingImports -> m a
handler
  Let Binding Src Import
a Expr Src Import
b              -> Binding Src Void -> Expr Src Void -> Expr Src Void
forall s a. Binding s a -> Expr s a -> Expr s a
Let (Binding Src Void -> Expr Src Void -> Expr Src Void)
-> StateT Status IO (Binding Src Void)
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> Binding Src Import -> StateT Status IO (Binding Src Void)
forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b)) -> Binding s a -> f (Binding s b)
bindingExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Binding Src Import
a StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b
  Record Map Text (RecordField Src Import)
m             -> Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
Record (Map Text (RecordField Src Void) -> Expr Src Void)
-> StateT Status IO (Map Text (RecordField Src Void))
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordField Src Import -> StateT Status IO (RecordField Src Void))
-> Map Text (RecordField Src Import)
-> StateT Status IO (Map Text (RecordField Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr Src Import -> StateT Status IO (Expr Src Void))
-> RecordField Src Import
-> StateT Status IO (RecordField Src Void)
forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
recordFieldExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith) Map Text (RecordField Src Import)
m
  RecordLit Map Text (RecordField Src Import)
m          -> Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit (Map Text (RecordField Src Void) -> Expr Src Void)
-> StateT Status IO (Map Text (RecordField Src Void))
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RecordField Src Import -> StateT Status IO (RecordField Src Void))
-> Map Text (RecordField Src Import)
-> StateT Status IO (Map Text (RecordField Src Void))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr Src Import -> StateT Status IO (Expr Src Void))
-> RecordField Src Import
-> StateT Status IO (RecordField Src Void)
forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> RecordField s a -> f (RecordField s b)
recordFieldExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith) Map Text (RecordField Src Import)
m
  Lam Maybe CharacterSet
cs FunctionBinding Src Import
a Expr Src Import
b           -> Maybe CharacterSet
-> FunctionBinding Src Void -> Expr Src Void -> Expr Src Void
forall s a.
Maybe CharacterSet -> FunctionBinding s a -> Expr s a -> Expr s a
Lam Maybe CharacterSet
cs (FunctionBinding Src Void -> Expr Src Void -> Expr Src Void)
-> StateT Status IO (FunctionBinding Src Void)
-> StateT Status IO (Expr Src Void -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> FunctionBinding Src Import
-> StateT Status IO (FunctionBinding Src Void)
forall (f :: * -> *) s a b.
Applicative f =>
(Expr s a -> f (Expr s b))
-> FunctionBinding s a -> f (FunctionBinding s b)
functionBindingExprs Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith FunctionBinding Src Import
a StateT Status IO (Expr Src Void -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
b
  Field Expr Src Import
a FieldSelection Src
b            -> Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field (Expr Src Void -> FieldSelection Src -> Expr Src Void)
-> StateT Status IO (Expr Src Void)
-> StateT Status IO (FieldSelection Src -> Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
a StateT Status IO (FieldSelection Src -> Expr Src Void)
-> StateT Status IO (FieldSelection Src)
-> StateT Status IO (Expr Src Void)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldSelection Src -> StateT Status IO (FieldSelection Src)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldSelection Src
b
  Expr Src Import
expression           -> (Expr Src Import -> StateT Status IO (Expr Src Void))
-> Expr Src Import -> StateT Status IO (Expr Src Void)
forall (f :: * -> *) s a t b.
Applicative f =>
(Expr s a -> f (Expr t b)) -> Expr s a -> f (Expr t b)
Syntax.unsafeSubExpressions Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expression

-- | Resolve all imports within an expression
load :: Expr Src Import -> IO (Expr Src Void)
load :: Expr Src Import -> IO (Expr Src Void)
load = IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager IO Manager
defaultNewManager

-- | See 'load'.
loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void)
loadWithManager IO Manager
newManager =
    Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus
        (IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
newManager IO (Expr Src Import)
defaultOriginHeaders String
".")
        SemanticCacheMode
UseSemanticCache

printWarning :: (MonadIO m) => String -> m ()
printWarning :: String -> m ()
printWarning String
message = do
    let warning :: String
warning =
                String
"\n"
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\ESC[1;33mWarning\ESC[0m: "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
message

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr String
warning

-- | Resolve all imports within an expression, importing relative to the given
-- directory.
loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo :: String
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo String
parentDirectory = Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus
    (IO Manager -> IO (Expr Src Import) -> String -> Status
makeEmptyStatus IO Manager
defaultNewManager IO (Expr Src Import)
defaultOriginHeaders String
parentDirectory)

-- | See 'loadRelativeTo'.
loadWithStatus
    :: Status
    -> SemanticCacheMode
    -> Expr Src Import
    -> IO (Expr Src Void)
loadWithStatus :: Status
-> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadWithStatus Status
status SemanticCacheMode
semanticCacheMode Expr Src Import
expression =
    StateT Status IO (Expr Src Void) -> Status -> IO (Expr Src Void)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT
        (Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith Expr Src Import
expression)
        Status
status { _semanticCacheMode :: SemanticCacheMode
_semanticCacheMode = SemanticCacheMode
semanticCacheMode }

encodeExpression :: Expr Void Void -> Data.ByteString.ByteString
encodeExpression :: Expr Void Void -> ByteString
encodeExpression Expr Void Void
expression = ByteString
bytesStrict
  where
    intermediateExpression :: Expr Void Import
    intermediateExpression :: Expr Void Import
intermediateExpression = (Void -> Import) -> Expr Void Void -> Expr Void Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
absurd Expr Void Void
expression

    encoding :: Encoding
encoding = Expr Void Import -> Encoding
forall a. Serialise a => a -> Encoding
Codec.Serialise.encode Expr Void Import
intermediateExpression

    bytesStrict :: ByteString
bytesStrict = Encoding -> ByteString
Write.toStrictByteString Encoding
encoding

-- | Hash a fully resolved expression
hashExpression :: Expr Void Void -> Dhall.Crypto.SHA256Digest
hashExpression :: Expr Void Void -> SHA256Digest
hashExpression = ByteString -> SHA256Digest
Dhall.Crypto.sha256Hash (ByteString -> SHA256Digest)
-> (Expr Void Void -> ByteString) -> Expr Void Void -> SHA256Digest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Void Void -> ByteString
encodeExpression

{-| Convenience utility to hash a fully resolved expression and return the
    base-16 encoded hash with the @sha256:@ prefix

    In other words, the output of this function can be pasted into Dhall
    source code to add an integrity check to an import
-}
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode :: Expr Void Void -> Text
hashExpressionToCode Expr Void Void
expr =
    Text
"sha256:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (SHA256Digest -> String
forall a. Show a => a -> String
show (Expr Void Void -> SHA256Digest
hashExpression Expr Void Void
expr))

-- | A call to `assertNoImports` failed because there was at least one import
data ImportResolutionDisabled = ImportResolutionDisabled deriving (Show ImportResolutionDisabled
Typeable ImportResolutionDisabled
Typeable ImportResolutionDisabled
-> Show ImportResolutionDisabled
-> (ImportResolutionDisabled -> SomeException)
-> (SomeException -> Maybe ImportResolutionDisabled)
-> (ImportResolutionDisabled -> String)
-> Exception ImportResolutionDisabled
SomeException -> Maybe ImportResolutionDisabled
ImportResolutionDisabled -> String
ImportResolutionDisabled -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ImportResolutionDisabled -> String
$cdisplayException :: ImportResolutionDisabled -> String
fromException :: SomeException -> Maybe ImportResolutionDisabled
$cfromException :: SomeException -> Maybe ImportResolutionDisabled
toException :: ImportResolutionDisabled -> SomeException
$ctoException :: ImportResolutionDisabled -> SomeException
$cp2Exception :: Show ImportResolutionDisabled
$cp1Exception :: Typeable ImportResolutionDisabled
Exception)

instance Show ImportResolutionDisabled where
    show :: ImportResolutionDisabled -> String
show ImportResolutionDisabled
_ = String
"\nImport resolution is disabled"

-- | Assert than an expression is import-free
assertNoImports :: MonadIO io => Expr Src Import -> io (Expr Src Void)
assertNoImports :: Expr Src Import -> io (Expr Src Void)
assertNoImports Expr Src Import
expression =
    Either ImportResolutionDisabled (Expr Src Void)
-> io (Expr Src Void)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws ((Import -> Either ImportResolutionDisabled Void)
-> Expr Src Import
-> Either ImportResolutionDisabled (Expr Src Void)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Import
_ -> ImportResolutionDisabled -> Either ImportResolutionDisabled Void
forall a b. a -> Either a b
Left ImportResolutionDisabled
ImportResolutionDisabled) Expr Src Import
expression)
{-# INLINABLE assertNoImports #-}

{-| This function is used by the @--transitive@ option of the
    @dhall {freeze,format,lint}@ subcommands to determine which dependencies
    to descend into

#ifndef mingw32_HOST_OS
    >>> dependencyToFile (emptyStatus ".") Import{ importHashed = ImportHashed{ hash = Nothing, importType = Local Here (File (Directory []) "foo") }, importMode = Code }
    Just "./foo"

    >>> dependencyToFile (emptyStatus "./foo") Import{ importHashed = ImportHashed{ hash = Nothing, importType = Local Here (File (Directory []) "bar") }, importMode = Code }
    Just "./foo/bar"


    >>> dependencyToFile (emptyStatus "./foo") Import{ importHashed = ImportHashed{ hash = Nothing, importType = Remote (URL HTTPS "example.com" (File (Directory []) "") Nothing Nothing) }, importMode = Code }
    Nothing

    >>> dependencyToFile (emptyStatus ".") Import{ importHashed = ImportHashed{ hash = Nothing, importType = Env "foo" }, importMode = Code }
    Nothing
#endif
-}
dependencyToFile :: Status -> Import -> IO (Maybe FilePath)
dependencyToFile :: Status -> Import -> IO (Maybe String)
dependencyToFile Status
status Import
import_ = (StateT Status IO (Maybe String) -> Status -> IO (Maybe String))
-> Status -> StateT Status IO (Maybe String) -> IO (Maybe String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Status IO (Maybe String) -> Status -> IO (Maybe String)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT Status
status (StateT Status IO (Maybe String) -> IO (Maybe String))
-> StateT Status IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
    Chained
parent :| [Chained]
_ <- LensLike' (Zooming IO (NonEmpty Chained)) Status (NonEmpty Chained)
-> StateT (NonEmpty Chained) IO (NonEmpty Chained)
-> StateT Status IO (NonEmpty Chained)
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming IO (NonEmpty Chained)) Status (NonEmpty Chained)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (NonEmpty Chained)
stack StateT (NonEmpty Chained) IO (NonEmpty Chained)
forall s (m :: * -> *). MonadState s m => m s
State.get

    Import
child <- (Chained -> Import)
-> StateT Status IO Chained -> StateT Status IO Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chained -> Import
chainedImport ((forall a. IO a -> IO a)
-> StateT Status IO Chained -> StateT Status IO Chained
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Chained -> Import -> StateT Status IO Chained
chainImport Chained
parent Import
import_))

    let ignore :: StateT Status IO (Maybe a)
ignore = Maybe a -> StateT Status IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

    -- We only need to transitively modify code imports since other import
    -- types are not interpreted and therefore don't need to be modified
    case Import -> ImportMode
importMode Import
child of
        ImportMode
RawText ->
            StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore

        ImportMode
Location ->
            StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore

        ImportMode
Code ->
            case ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
child) of
                Local FilePrefix
filePrefix File
file -> do
                    let descend :: StateT Status IO (Maybe String)
descend = IO (Maybe String) -> StateT Status IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> StateT Status IO (Maybe String))
-> IO (Maybe String) -> StateT Status IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                            String
path <- FilePrefix -> File -> IO String
forall (io :: * -> *).
MonadIO io =>
FilePrefix -> File -> io String
localToPath FilePrefix
filePrefix File
file

                            Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
path)

                    -- Only follow relative imports when modifying dependencies.
                    -- Carefully note that we check the file prefix of the
                    -- original import (before chaining), since the chained
                    -- import will inherit the file prefix of the parent import.
                    case ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
import_) of
                        Local FilePrefix
Here   File
_ -> StateT Status IO (Maybe String)
descend
                        Local FilePrefix
Parent File
_ -> StateT Status IO (Maybe String)
descend
                        ImportType
_              -> StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore

                -- Don't transitively modify any other type of import
                Remote{} ->
                    StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore

                ImportType
Missing ->
                    StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore

                Env{} ->
                    StateT Status IO (Maybe String)
forall a. StateT Status IO (Maybe a)
ignore