{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-# OPTIONS_GHC -Wall #-}

module Dhall.Import.Types where

import Control.Exception                (Exception)
import Control.Monad.Trans.State.Strict (StateT)
import Data.ByteString                  (ByteString)
import Data.CaseInsensitive             (CI)
import Data.Dynamic
import Data.HashMap.Strict              (HashMap)
import Data.List.NonEmpty               (NonEmpty)
import Data.Void                        (Void)
import Dhall.Context                    (Context)
import Dhall.Core
    ( Expr
    , Import (..)
    , ReifiedNormalizer (..)
    , URL
    )
import Dhall.Map                        (Map)
import Dhall.Parser                     (Src)
import Lens.Micro                       (Lens', lens)
import Prettyprinter                    (Pretty (..))

#ifdef WITH_HTTP
import qualified Dhall.Import.Manager
#endif

import qualified Data.Text
import qualified Dhall.Context
import qualified Dhall.Map          as Map
import qualified Dhall.Substitution

-- | A fully \"chained\" import, i.e. if it contains a relative path that path
--   is relative to the current directory. If it is a remote import with headers
--   those are well-typed (either of type `List { header : Text, value Text}` or
--   `List { mapKey : Text, mapValue Text})` and in normal form. These
--   invariants are preserved by the API exposed by @Dhall.Import@.
newtype Chained = Chained
    { Chained -> Import
chainedImport :: Import
      -- ^ The underlying import
    }
  deriving (Chained -> Chained -> Bool
(Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool) -> Eq Chained
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Chained -> Chained -> Bool
== :: Chained -> Chained -> Bool
$c/= :: Chained -> Chained -> Bool
/= :: Chained -> Chained -> Bool
Eq, Eq Chained
Eq Chained =>
(Chained -> Chained -> Ordering)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Bool)
-> (Chained -> Chained -> Chained)
-> (Chained -> Chained -> Chained)
-> Ord Chained
Chained -> Chained -> Bool
Chained -> Chained -> Ordering
Chained -> Chained -> Chained
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Chained -> Chained -> Ordering
compare :: Chained -> Chained -> Ordering
$c< :: Chained -> Chained -> Bool
< :: Chained -> Chained -> Bool
$c<= :: Chained -> Chained -> Bool
<= :: Chained -> Chained -> Bool
$c> :: Chained -> Chained -> Bool
> :: Chained -> Chained -> Bool
$c>= :: Chained -> Chained -> Bool
>= :: Chained -> Chained -> Bool
$cmax :: Chained -> Chained -> Chained
max :: Chained -> Chained -> Chained
$cmin :: Chained -> Chained -> Chained
min :: Chained -> Chained -> Chained
Ord)

instance Pretty Chained where
    pretty :: forall ann. Chained -> Doc ann
pretty (Chained Import
import_) = Import -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Import -> Doc ann
pretty Import
import_

-- | An import that has been fully interpeted
newtype ImportSemantics = ImportSemantics
    { ImportSemantics -> Expr Void Void
importSemantics :: Expr Void Void
    -- ^ The fully resolved import, typechecked and beta-normal.
    }

-- | `parent` imports (i.e. depends on) `child`
data Depends = Depends { Depends -> Chained
parent :: Chained, Depends -> Chained
child :: Chained }

{-| This enables or disables the semantic cache for imports protected by
    integrity checks
-}
data SemanticCacheMode = IgnoreSemanticCache | UseSemanticCache deriving (SemanticCacheMode -> SemanticCacheMode -> Bool
(SemanticCacheMode -> SemanticCacheMode -> Bool)
-> (SemanticCacheMode -> SemanticCacheMode -> Bool)
-> Eq SemanticCacheMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemanticCacheMode -> SemanticCacheMode -> Bool
== :: SemanticCacheMode -> SemanticCacheMode -> Bool
$c/= :: SemanticCacheMode -> SemanticCacheMode -> Bool
/= :: SemanticCacheMode -> SemanticCacheMode -> Bool
Eq)

-- | Shared state for HTTP requests
type Manager =
#ifdef WITH_HTTP
    Dhall.Import.Manager.Manager
#else
    ()
#endif

-- | The default HTTP 'Manager'
defaultNewManager :: IO Manager
defaultNewManager :: IO Manager
defaultNewManager =
#ifdef WITH_HTTP
  IO Manager
Dhall.Import.Manager.defaultNewManager
#else
  pure ()
#endif

-- | HTTP headers
type HTTPHeader = (CI ByteString, ByteString)

-- | A map of site origin -> HTTP headers
type OriginHeaders = HashMap Data.Text.Text [HTTPHeader]

{-| Used internally to track whether or not we've already warned the user about
    caching issues
-}
data CacheWarning = CacheNotWarned | CacheWarned

-- | State threaded throughout the import process
data Status = Status
    { Status -> NonEmpty Chained
_stack :: NonEmpty Chained
    -- ^ Stack of `Import`s that we've imported along the way to get to the
    -- current point

    , Status -> [Depends]
_graph :: [Depends]
    -- ^ Graph of all the imports visited so far, represented by a list of
    --   import dependencies.

    , Status -> Map Chained ImportSemantics
_cache :: Map Chained ImportSemantics
    -- ^ Cache of imported expressions with their node id in order to avoid
    --   importing the same expression twice with different values

    , Status -> IO Manager
_newManager :: IO Manager
    , Status -> Maybe Manager
_manager :: Maybe Manager
    -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple
    -- requests

    , Status -> StateT Status IO OriginHeaders
_loadOriginHeaders :: StateT Status IO OriginHeaders
    -- ^ Load the origin headers from environment or configuration file.
    --   After loading once, further evaluations return the cached version.

    , Status -> URL -> StateT Status IO Text
_remote :: URL -> StateT Status IO Data.Text.Text
    -- ^ The remote resolver, fetches the content at the given URL.

    , Status -> URL -> StateT Status IO ByteString
_remoteBytes :: URL -> StateT Status IO Data.ByteString.ByteString
    -- ^ Like `_remote`, except for `Dhall.Syntax.Expr.Bytes`

    , Status -> Substitutions Src Void
_substitutions :: Dhall.Substitution.Substitutions Src Void

    , Status -> Maybe (ReifiedNormalizer Void)
_normalizer :: Maybe (ReifiedNormalizer Void)

    , Status -> Context (Expr Src Void)
_startingContext :: Context (Expr Src Void)

    , Status -> SemanticCacheMode
_semanticCacheMode :: SemanticCacheMode

    , Status -> CacheWarning
_cacheWarning :: CacheWarning
    -- ^ Records whether or not we already warned the user about issues with
    --   cache directory
    }

-- | Initial `Status`, parameterised over the HTTP 'Manager',
--   the origin headers and the remote resolver,
--   importing relative to the given root import.
emptyStatusWith
    :: IO Manager
    -> StateT Status IO OriginHeaders
    -> (URL -> StateT Status IO Data.Text.Text)
    -> (URL -> StateT Status IO Data.ByteString.ByteString)
    -> Import
    -> Status
emptyStatusWith :: IO Manager
-> StateT Status IO OriginHeaders
-> (URL -> StateT Status IO Text)
-> (URL -> StateT Status IO ByteString)
-> Import
-> Status
emptyStatusWith IO Manager
_newManager StateT Status IO OriginHeaders
_loadOriginHeaders URL -> StateT Status IO Text
_remote URL -> StateT Status IO ByteString
_remoteBytes Import
rootImport = Status {[Depends]
Maybe Manager
Maybe (ReifiedNormalizer Void)
IO Manager
NonEmpty Chained
Context (Expr Src Void)
StateT Status IO OriginHeaders
Substitutions Src Void
Map Chained ImportSemantics
CacheWarning
SemanticCacheMode
URL -> StateT Status IO Text
URL -> StateT Status IO ByteString
forall {a}. [a]
forall {a}. Maybe a
forall {a}. Context a
forall {v}. Map Chained v
forall {s} {a}. Substitutions s a
_stack :: NonEmpty Chained
_graph :: [Depends]
_cache :: Map Chained ImportSemantics
_newManager :: IO Manager
_manager :: Maybe Manager
_loadOriginHeaders :: StateT Status IO OriginHeaders
_remote :: URL -> StateT Status IO Text
_remoteBytes :: URL -> StateT Status IO ByteString
_substitutions :: Substitutions Src Void
_normalizer :: Maybe (ReifiedNormalizer Void)
_startingContext :: Context (Expr Src Void)
_semanticCacheMode :: SemanticCacheMode
_cacheWarning :: CacheWarning
_newManager :: IO Manager
_loadOriginHeaders :: StateT Status IO OriginHeaders
_remote :: URL -> StateT Status IO Text
_remoteBytes :: URL -> StateT Status IO ByteString
_stack :: NonEmpty Chained
_graph :: forall {a}. [a]
_cache :: forall {v}. Map Chained v
_manager :: forall {a}. Maybe a
_substitutions :: forall {s} {a}. Substitutions s a
_normalizer :: forall {a}. Maybe a
_startingContext :: forall {a}. Context a
_semanticCacheMode :: SemanticCacheMode
_cacheWarning :: CacheWarning
..}
  where
    _stack :: NonEmpty Chained
_stack = Chained -> NonEmpty Chained
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Import -> Chained
Chained Import
rootImport)

    _graph :: [a]
_graph = []

    _cache :: Map Chained v
_cache = Map Chained v
forall k v. Ord k => Map k v
Map.empty

    _manager :: Maybe a
_manager = Maybe a
forall {a}. Maybe a
Nothing

    _substitutions :: Substitutions s a
_substitutions = Substitutions s a
forall {s} {a}. Substitutions s a
Dhall.Substitution.empty

    _normalizer :: Maybe a
_normalizer = Maybe a
forall {a}. Maybe a
Nothing

    _startingContext :: Context a
_startingContext = Context a
forall {a}. Context a
Dhall.Context.empty

    _semanticCacheMode :: SemanticCacheMode
_semanticCacheMode = SemanticCacheMode
UseSemanticCache

    _cacheWarning :: CacheWarning
_cacheWarning = CacheWarning
CacheNotWarned

-- | Lens from a `Status` to its `_stack` field
stack :: Lens' Status (NonEmpty Chained)
stack :: Lens' Status (NonEmpty Chained)
stack = (Status -> NonEmpty Chained)
-> (Status -> NonEmpty Chained -> Status)
-> Lens' Status (NonEmpty Chained)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> NonEmpty Chained
_stack (\Status
s NonEmpty Chained
x -> Status
s { _stack = x })

-- | Lens from a `Status` to its `_graph` field
graph :: Lens' Status [Depends]
graph :: Lens' Status [Depends]
graph = (Status -> [Depends])
-> (Status -> [Depends] -> Status) -> Lens' Status [Depends]
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> [Depends]
_graph (\Status
s [Depends]
x -> Status
s { _graph = x })

-- | Lens from a `Status` to its `_cache` field
cache :: Lens' Status (Map Chained ImportSemantics)
cache :: Lens' Status (Map Chained ImportSemantics)
cache = (Status -> Map Chained ImportSemantics)
-> (Status -> Map Chained ImportSemantics -> Status)
-> Lens' Status (Map Chained ImportSemantics)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> Map Chained ImportSemantics
_cache (\Status
s Map Chained ImportSemantics
x -> Status
s { _cache = x })

-- | Lens from a `Status` to its `_remote` field
remote :: Lens' Status (URL -> StateT Status IO Data.Text.Text)
remote :: Lens' Status (URL -> StateT Status IO Text)
remote = (Status -> URL -> StateT Status IO Text)
-> (Status -> (URL -> StateT Status IO Text) -> Status)
-> Lens' Status (URL -> StateT Status IO Text)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> URL -> StateT Status IO Text
_remote (\Status
s URL -> StateT Status IO Text
x -> Status
s { _remote = x })

-- | Lens from a `Status` to its `_remote` field
remoteBytes :: Lens' Status (URL -> StateT Status IO Data.ByteString.ByteString)
remoteBytes :: Lens' Status (URL -> StateT Status IO ByteString)
remoteBytes = (Status -> URL -> StateT Status IO ByteString)
-> (Status -> (URL -> StateT Status IO ByteString) -> Status)
-> Lens' Status (URL -> StateT Status IO ByteString)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> URL -> StateT Status IO ByteString
_remoteBytes (\Status
s URL -> StateT Status IO ByteString
x -> Status
s { _remoteBytes = x })

-- | Lens from a `Status` to its `_substitutions` field
substitutions :: Lens' Status (Dhall.Substitution.Substitutions Src Void)
substitutions :: Lens' Status (Substitutions Src Void)
substitutions = (Status -> Substitutions Src Void)
-> (Status -> Substitutions Src Void -> Status)
-> Lens' Status (Substitutions Src Void)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> Substitutions Src Void
_substitutions (\Status
s Substitutions Src Void
x -> Status
s { _substitutions = x })

-- | Lens from a `Status` to its `_normalizer` field
normalizer :: Lens' Status (Maybe (ReifiedNormalizer Void))
normalizer :: Lens' Status (Maybe (ReifiedNormalizer Void))
normalizer = (Status -> Maybe (ReifiedNormalizer Void))
-> (Status -> Maybe (ReifiedNormalizer Void) -> Status)
-> Lens' Status (Maybe (ReifiedNormalizer Void))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> Maybe (ReifiedNormalizer Void)
_normalizer (\Status
s Maybe (ReifiedNormalizer Void)
x -> Status
s {_normalizer = x})

-- | Lens from a `Status` to its `_startingContext` field
startingContext :: Lens' Status (Context (Expr Src Void))
startingContext :: Lens' Status (Context (Expr Src Void))
startingContext = (Status -> Context (Expr Src Void))
-> (Status -> Context (Expr Src Void) -> Status)
-> Lens' Status (Context (Expr Src Void))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> Context (Expr Src Void)
_startingContext (\Status
s Context (Expr Src Void)
x -> Status
s { _startingContext = x })

-- | Lens from a `Status` to its `_cacheWarning` field
cacheWarning :: Lens' Status CacheWarning
cacheWarning :: Lens' Status CacheWarning
cacheWarning = (Status -> CacheWarning)
-> (Status -> CacheWarning -> Status) -> Lens' Status CacheWarning
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Status -> CacheWarning
_cacheWarning (\Status
s CacheWarning
x -> Status
s { _cacheWarning = x })

{-| This exception indicates that there was an internal error in Dhall's
    import-related logic

    This exception indicates that an invalid `Dhall.Syntax.Type` was provided to
    the `Dhall.input` function
-}
data InternalError = InternalError deriving (Typeable)


instance Show InternalError where
    show :: InternalError -> String
show InternalError
InternalError = [String] -> String
unlines
        [ String
_ERROR String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Compiler bug                                                        "
        , String
"                                                                                "
        , String
"Explanation: This error message means that there is a bug in the Dhall compiler."
        , String
"You didn't do anything wrong, but if you would like to see this problem fixed   "
        , String
"then you should report the bug at:                                              "
        , String
"                                                                                "
        , String
"https://github.com/dhall-lang/dhall-haskell/issues                              "
        , String
"                                                                                "
        , String
"Please include the following text in your bug report:                           "
        , String
"                                                                                "
        , String
"```                                                                             "
        , String
"Header extraction failed even though the header type-checked                    "
        , String
"```                                                                             "
        ]
      where
        _ERROR :: String
        _ERROR :: String
_ERROR = String
"\ESC[1;31mError\ESC[0m"

instance Exception InternalError

-- | Wrapper around `Network.HTTP.Client.HttpException`s with a prettier `Show`
-- instance
--
-- In order to keep the library API constant even when the @with-http@ Cabal
-- flag is disabled the pretty error message is pre-rendered and the real
-- 'Network.HTTP.Client.HttpException' is stored in a 'Dynamic'
data PrettyHttpException = PrettyHttpException String Dynamic
    deriving (Typeable)

instance Exception PrettyHttpException

instance Show PrettyHttpException where
  show :: PrettyHttpException -> String
show (PrettyHttpException String
msg Dynamic
_) = String
msg