module Dhall.Import (
exprFromPath
, load
, Cycle(..)
, ReferentiallyOpaque(..)
, Imported(..)
, PrettyHttpException(..)
, MissingFile(..)
) where
import Control.Exception
(Exception, IOException, SomeException, catch, onException, throwIO)
import Control.Lens (Lens', zoom)
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State.Strict (StateT)
import Data.ByteString.Lazy (ByteString)
import Data.Map.Strict (Map)
import Data.Monoid ((<>))
import Data.Text.Buildable (build)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder)
#if MIN_VERSION_base(4,8,0)
#else
import Data.Traversable (traverse)
#endif
import Data.Typeable (Typeable)
import Filesystem.Path ((</>), FilePath)
import Dhall.Core
(Expr(..), HasHome(..), PathMode(..), PathType(..), Path(..))
import Dhall.Parser (Parser(..), ParseError(..), Src)
import Dhall.TypeCheck (X(..))
#if MIN_VERSION_http_client(0,5,0)
import Network.HTTP.Client
(HttpException(..), HttpExceptionContent(..), Manager)
#else
import Network.HTTP.Client (HttpException(..), Manager)
#endif
import Prelude hiding (FilePath)
import Text.Trifecta (Result(..))
import Text.Trifecta.Delta (Delta(..))
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.ByteString.Lazy
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy.Encoding
import qualified Dhall.Parser
import qualified Dhall.TypeCheck
import qualified Filesystem
import qualified Filesystem.Path.CurrentOS
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Filesystem.Path.CurrentOS as Filesystem
import qualified System.Environment
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token
import qualified Text.Trifecta
builderToString :: Builder -> String
builderToString = Text.unpack . Builder.toLazyText
newtype Cycle = Cycle
{ cyclicImport :: Path
}
deriving (Typeable)
instance Exception Cycle
instance Show Cycle where
show (Cycle path) = "\nCyclic import: " ++ builderToString (build path)
newtype ReferentiallyOpaque = ReferentiallyOpaque
{ opaqueImport :: Path
} deriving (Typeable)
instance Exception ReferentiallyOpaque
instance Show ReferentiallyOpaque where
show (ReferentiallyOpaque path) =
"\nReferentially opaque import: " ++ builderToString (build path)
data Imported e = Imported
{ importStack :: [Path]
, nested :: e
} deriving (Typeable)
instance Exception e => Exception (Imported e)
instance Show e => Show (Imported e) where
show (Imported paths e) =
(case paths of [] -> ""; _ -> "\n")
++ unlines (map indent paths')
++ show e
where
indent (n, path) =
take (2 * n) (repeat ' ') ++ "↳ " ++ builderToString (build path)
paths' = zip [0..] (drop 1 (reverse (canonicalizeAll paths)))
newtype PrettyHttpException = PrettyHttpException HttpException
deriving (Typeable)
instance Exception PrettyHttpException
#if MIN_VERSION_http_client(0,5,0)
instance Show PrettyHttpException where
show (PrettyHttpException (InvalidUrlException _ r)) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Invalid URL\n"
<> "\n"
<> "↳ " <> show r
show (PrettyHttpException (HttpExceptionRequest _ e)) = case e of
ConnectionFailure e' ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Wrong host\n"
<> "\n"
<> "↳ " <> show e'
InvalidDestinationHost host ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Invalid host name\n"
<> "\n"
<> "↳ " <> show host
ResponseTimeout ->
"\ESC[1;31mError\ESC[0m: The host took too long to respond\n"
e' -> "\n" <> show e'
#else
instance Show PrettyHttpException where
show (PrettyHttpException e) = case e of
FailedConnectionException2 _ _ _ e' ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Wrong host\n"
<> "\n"
<> "↳ " <> show e'
InvalidDestinationHost host ->
"\n"
<> "\ESC[1;31mError\ESC[0m: Invalid host name\n"
<> "\n"
<> "↳ " <> show host
ResponseTimeout ->
"\ESC[1;31mError\ESC[0m: The host took too long to respond\n"
e' -> "\n"
<> show e'
#endif
data MissingFile = MissingFile
deriving (Typeable)
instance Exception MissingFile
instance Show MissingFile where
show MissingFile =
"\n"
<> "\ESC[1;31mError\ESC[0m: Missing file\n"
newtype MissingEnvironmentVariable = MissingEnvironmentVariable { name :: Text }
deriving (Typeable)
instance Exception MissingEnvironmentVariable
instance Show MissingEnvironmentVariable where
show (MissingEnvironmentVariable {..}) =
"\n"
<> "\ESC[1;31mError\ESC[0m: Missing environment variable\n"
<> "\n"
<> "↳ " <> Text.unpack name
data Status = Status
{ _stack :: [Path]
, _cache :: Map Path (Expr Src X)
, _manager :: Maybe Manager
}
canonicalizeAll :: [Path] -> [Path]
canonicalizeAll = map canonicalizePath . List.tails
stack :: Lens' Status [Path]
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
cache :: Lens' Status (Map Path (Expr Src X))
cache k s = fmap (\x -> s { _cache = x }) (k (_cache s))
manager :: Lens' Status (Maybe Manager)
manager k s = fmap (\x -> s { _manager = x }) (k (_manager s))
needManager :: StateT Status IO Manager
needManager = do
x <- zoom manager State.get
case x of
Just m -> return m
Nothing -> do
let settings = HTTP.tlsManagerSettings
#if MIN_VERSION_http_client(0,5,0)
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) }
#else
{ HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) }
#endif
m <- liftIO (HTTP.newManager settings)
zoom manager (State.put (Just m))
return m
canonicalize :: [PathType] -> PathType
canonicalize [] = File Homeless "."
canonicalize (File hasHome0 file0:paths0) =
if Filesystem.relative file0 && hasHome0 == Homeless
then go file0 paths0
else File hasHome0 (clean file0)
where
go currPath [] = File hasHome0 (clean currPath)
go currPath (Env _ :_ ) = File hasHome0 (clean currPath)
go currPath (URL url0:_ ) = combine prefix suffix
where
prefix = parentURL (removeAtFromURL url0)
suffix = clean currPath
combine url path = case Filesystem.stripPrefix ".." path of
Just path' -> combine url' path'
where
url' = parentURL (removeAtFromURL url)
Nothing -> case Filesystem.stripPrefix "." path of
Just path' -> combine url path'
Nothing ->
case Text.last url of
'/' -> URL (url <> path')
_ -> URL (url <> "/" <> path')
where
path' = Text.fromStrict (case Filesystem.toText path of
Left txt -> txt
Right txt -> txt )
go currPath (File hasHome file:paths) =
if Filesystem.relative file && hasHome == Homeless
then go file' paths
else File hasHome0 (clean file')
where
file' = Filesystem.parent (removeAtFromFile file) </> currPath
canonicalize (URL path:_) = URL path
canonicalize (Env env :_) = Env env
canonicalizePath :: [Path] -> Path
canonicalizePath [] =
Path
{ pathMode = Code
, pathType = canonicalize []
}
canonicalizePath (path:paths) =
Path
{ pathMode = pathMode path
, pathType = canonicalize (map pathType (path:paths))
}
parentURL :: Text -> Text
parentURL = Text.dropWhileEnd (/= '/')
removeAtFromURL:: Text -> Text
removeAtFromURL url
| Text.isSuffixOf "/@" url = Text.dropEnd 2 url
| Text.isSuffixOf "/" url = Text.dropEnd 1 url
| otherwise = url
removeAtFromFile :: FilePath -> FilePath
removeAtFromFile file =
if Filesystem.filename file == "@"
then Filesystem.parent file
else file
clean :: FilePath -> FilePath
clean = strip . Filesystem.collapse
where
strip p = case Filesystem.stripPrefix "." p of
Nothing -> p
Just p' -> p'
exprFromPath :: Manager -> Path -> IO (Expr Src Path)
exprFromPath m (Path {..}) = case pathType of
File hasHome file -> do
path <- case hasHome of
Home -> do
home <- liftIO Filesystem.getHomeDirectory
return (home </> file)
Homeless -> do
return file
case pathMode of
Code -> do
exists <- Filesystem.isFile path
if exists
then return ()
else Control.Exception.throwIO MissingFile
let string = Filesystem.Path.CurrentOS.encodeString path
let handler :: IOException -> IO (Result (Expr Src Path))
handler e = do
let string' =
Filesystem.Path.CurrentOS.encodeString
(path </> "@")
Text.Trifecta.parseFromFileEx parser string'
`onException` throwIO e
x <- Text.Trifecta.parseFromFileEx parser string `catch` handler
case x of
Failure errInfo -> do
throwIO (ParseError (Text.Trifecta._errDoc errInfo))
Success expr -> do
return expr
RawText -> do
text <- Filesystem.readTextFile path
return (TextLit (build text))
URL url -> do
request <- HTTP.parseUrlThrow (Text.unpack url)
let handler :: HTTP.HttpException -> IO (HTTP.Response ByteString)
#if MIN_VERSION_http_client(0,5,0)
handler err@(HttpExceptionRequest _ (StatusCodeException _ _)) = do
#else
handler err@(StatusCodeException _ _ _) = do
#endif
let request' = request { HTTP.path = HTTP.path request <> "/@" }
HTTP.httpLbs request' m `onException` throwIO (PrettyHttpException err)
handler err = throwIO (PrettyHttpException err)
response <- HTTP.httpLbs request m `catch` handler
let bytes = HTTP.responseBody response
text <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes of
Left err -> throwIO err
Right text -> return text
case pathMode of
Code -> do
let urlBytes = Data.Text.Lazy.Encoding.encodeUtf8 url
let delta =
Directed (Data.ByteString.Lazy.toStrict urlBytes) 0 0 0 0
case Text.Trifecta.parseString parser delta (Text.unpack text) of
Failure err -> do
let err' = ParseError (Text.Trifecta._errDoc err)
request' <- HTTP.parseUrlThrow (Text.unpack url)
let request'' =
request'
{ HTTP.path = HTTP.path request' <> "/@" }
response' <- HTTP.httpLbs request'' m
`onException` throwIO err'
let bytes' = HTTP.responseBody response'
text' <- case Data.Text.Lazy.Encoding.decodeUtf8' bytes' of
Left _ -> throwIO err'
Right text' -> return text'
case Text.Trifecta.parseString parser delta (Text.unpack text') of
Failure _ -> throwIO err'
Success expr -> return expr
Success expr -> return expr
RawText -> do
return (TextLit (build text))
Env env -> do
x <- System.Environment.lookupEnv (Text.unpack env)
case x of
Just str -> do
case pathMode of
Code -> do
let envBytes = Data.Text.Lazy.Encoding.encodeUtf8 env
let delta =
Directed (Data.ByteString.Lazy.toStrict envBytes) 0 0 0 0
case Text.Trifecta.parseString parser delta str of
Failure errInfo -> do
throwIO (ParseError (Text.Trifecta._errDoc errInfo))
Success expr -> do
return expr
RawText -> return (TextLit (build str))
Nothing -> throwIO (MissingEnvironmentVariable env)
where
parser = unParser (do
Text.Parser.Token.whiteSpace
r <- Dhall.Parser.expr
Text.Parser.Combinators.eof
return r )
loadDynamic :: Path -> StateT Status IO (Expr Src Path)
loadDynamic p = do
paths <- zoom stack State.get
let handler :: SomeException -> IO (Expr Src Path)
handler e = throwIO (Imported (p:paths) e)
m <- needManager
liftIO (exprFromPath m (canonicalizePath (p:paths)) `catch` handler)
loadStatic :: Path -> StateT Status IO (Expr Src X)
loadStatic path = do
paths <- zoom stack State.get
let local (Path (URL url ) _) = case HTTP.parseUrlThrow (Text.unpack url) of
Nothing -> False
Just request -> case HTTP.host request of
"127.0.0.1" -> True
"localhost" -> True
_ -> False
local (Path (File _ _) _) = True
local (Path (Env _ ) _) = True
let parent = canonicalizePath paths
let here = canonicalizePath (path:paths)
if local here && not (local parent)
then liftIO (throwIO (Imported paths (ReferentiallyOpaque path)))
else return ()
(expr, cached) <- if here `elem` canonicalizeAll paths
then liftIO (throwIO (Imported paths (Cycle path)))
else do
m <- zoom cache State.get
case Map.lookup here m of
Just expr -> return (expr, True)
Nothing -> do
expr' <- loadDynamic path
expr'' <- case traverse (\_ -> Nothing) expr' of
Just expr -> do
zoom cache (State.put $! Map.insert here expr m)
return expr
Nothing -> do
let paths' = path:paths
zoom stack (State.put paths')
expr'' <- fmap join (traverse loadStatic expr')
zoom stack (State.put paths)
return expr''
return (expr'', False)
if cached
then return ()
else case Dhall.TypeCheck.typeOf expr of
Left err -> liftIO (throwIO (Imported (path:paths) err))
Right _ -> return ()
return expr
load :: Expr Src Path -> IO (Expr Src X)
load expr = State.evalStateT (fmap join (traverse loadStatic expr)) status
where
status = Status [] Map.empty Nothing