module Morte.Import (
load
, Cycle(..)
, ReferentiallyOpaque(..)
, Imported(..)
) where
import Control.Exception (Exception, IOException, catch, onException, throwIO)
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Managed (Managed, managed, with)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import Data.Text.Buildable (build)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import Data.Traversable (traverse)
import Data.Typeable (Typeable)
import Filesystem.Path ((</>))
import Filesystem as Filesystem
import Lens.Micro (Lens')
import Lens.Micro.Mtl (zoom)
import Network.HTTP.Client (Manager)
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import Prelude hiding (FilePath)
import Morte.Core (Expr, Path(..), X(..), typeOf)
import Morte.Parser (exprFromText)
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) = "Cyclic import: " ++ builderToString (build path)
newtype ReferentiallyOpaque = ReferentiallyOpaque
{ opaqueImport :: Path
} deriving (Typeable)
instance Exception ReferentiallyOpaque
instance Show ReferentiallyOpaque where
show (ReferentiallyOpaque path) =
"Referentially 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) =
"\n"
++ unlines (map (\path -> "⤷ " ++ builderToString (build path))
(reverse paths) )
++ show e
data Status = Status
{ _stack :: [Path]
, _cache :: Map Path (Expr X)
, _manager :: Maybe Manager
}
stack :: Lens' Status [Path]
stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))
cache :: Lens' Status (Map Path (Expr 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 Managed Manager
needManager = do
x <- zoom manager get
case x of
Just m -> return m
Nothing -> do
let settings = HTTP.tlsManagerSettings
{ HTTP.managerResponseTimeout = Just 1000000 }
m <- lift (managed (HTTP.withManager settings))
zoom manager (put (Just m))
return m
loadDynamic :: Path -> StateT Status Managed (Expr Path)
loadDynamic p = do
paths <- zoom stack get
txt <- case p of
File file -> do
let readFile' = do
Filesystem.readTextFile file `catch` (\e -> do
let _ = e :: IOException
Filesystem.readTextFile (file </> "@")
`onException` throwIO e )
liftIO (fmap Text.fromStrict readFile')
URL url -> do
request <- liftIO (HTTP.parseUrl url)
m <- needManager
let httpLbs' = do
HTTP.httpLbs request m `catch` (\e -> case e of
HTTP.StatusCodeException _ _ _ -> do
let request' = request
{ HTTP.path = HTTP.path request <> "/@" }
HTTP.httpLbs request' m `onException` throwIO e
_ -> throwIO e )
response <- liftIO httpLbs'
case Text.decodeUtf8' (HTTP.responseBody response) of
Left err -> liftIO (throwIO err)
Right txt -> return txt
let abort err = liftIO (throwIO (Imported paths err))
case exprFromText txt of
Left err -> case p of
URL url -> do
request <- liftIO (HTTP.parseUrl url)
let request' = request { HTTP.path = HTTP.path request <> "/@" }
m <- needManager
response <- liftIO
(HTTP.httpLbs request' m `onException` abort err)
case Text.decodeUtf8' (HTTP.responseBody response) of
Left _ -> liftIO (abort err)
Right txt' -> case exprFromText txt' of
Left _ -> liftIO (abort err)
Right expr -> return expr
_ -> liftIO (abort err)
Right expr -> return expr
loadStatic :: Path -> StateT Status Managed (Expr X)
loadStatic path = do
paths <- zoom stack get
let local (URL url) = case HTTP.parseUrl url of
Nothing -> False
Just request -> case HTTP.host request of
"127.0.0.1" -> True
"localhost" -> True
_ -> False
local (File _) = True
case paths of
parent:_ ->
if local path && not (local parent)
then liftIO (throwIO (Imported paths (ReferentiallyOpaque path)))
else return ()
_ -> return ()
let paths' = path:paths
zoom stack (put paths')
expr <- if path `elem` paths
then liftIO (throwIO (Imported paths (Cycle path)))
else do
m <- zoom cache get
case Map.lookup path m of
Just expr -> return expr
Nothing -> do
expr' <- loadDynamic path
case traverse (\_ -> Nothing) expr' of
Just expr -> do
zoom cache (put $! Map.insert path expr m)
return expr
Nothing -> fmap join (traverse loadStatic expr')
case typeOf expr of
Left err -> liftIO (throwIO (Imported paths' err))
Right _ -> return ()
zoom stack (put paths)
return expr
load :: Expr Path -> IO (Expr X)
load expr =
with (evalStateT (fmap join (traverse loadStatic expr)) status) return
where
status = Status [] Map.empty Nothing