Types.hs

{-# 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
    { chainedImport :: Import
      -- ^ The underlying import
    }
  deriving (Eq, Ord)

instance Pretty Chained where
    pretty (Chained import_) = pretty import_

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

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

{-| This enables or disables the semantic cache for imports protected by
    integrity checks
-}
data SemanticCacheMode = IgnoreSemanticCache | UseSemanticCache deriving (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 =
#ifdef WITH_HTTP
  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
    { _stack :: NonEmpty Chained
    -- ^ Stack of `Import`s that we've imported along the way to get to the
    -- current point

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

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

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

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

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

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

    , _substitutions :: Dhall.Substitution.Substitutions Src Void

    , _normalizer :: Maybe (ReifiedNormalizer Void)

    , _startingContext :: Context (Expr Src Void)

    , _semanticCacheMode :: SemanticCacheMode

    , _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 _newManager _loadOriginHeaders _remote _remoteBytes rootImport = Status {..}
  where
    _stack = pure (Chained rootImport)

    _graph = []

    _cache = Map.empty

    _manager = Nothing

    _substitutions = Dhall.Substitution.empty

    _normalizer = Nothing

    _startingContext = Dhall.Context.empty

    _semanticCacheMode = UseSemanticCache

    _cacheWarning = CacheNotWarned

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

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

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

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

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

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

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

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

-- | Lens from a `Status` to its `_cacheWarning` field
cacheWarning :: Lens' Status CacheWarning
cacheWarning = lens _cacheWarning (\s x -> 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 = unlines
        [ _ERROR <> ": Compiler bug                                                        "
        , "                                                                                "
        , "Explanation: This error message means that there is a bug in the Dhall compiler."
        , "You didn't do anything wrong, but if you would like to see this problem fixed   "
        , "then you should report the bug at:                                              "
        , "                                                                                "
        , "https://github.com/dhall-lang/dhall-haskell/issues                              "
        , "                                                                                "
        , "Please include the following text in your bug report:                           "
        , "                                                                                "
        , "```                                                                             "
        , "Header extraction failed even though the header type-checked                    "
        , "```                                                                             "
        ]
      where
        _ERROR :: String
        _ERROR = "\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 msg _) = msg