{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.Yaml.Include (
  decodeFile
, decodeFileEither
, decodeFileWithWarnings
) where

#if !MIN_VERSION_directory(1, 2, 3)
import Control.Exception (handleJust)
import Control.Monad (guard)
import System.IO.Error (ioeGetFileName, ioeGetLocation, isDoesNotExistError)
#endif

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON)
import Data.Text (unpack)
import Data.Text.Encoding (decodeUtf8)
import System.Directory
import System.FilePath

import Data.Yaml.Internal (ParseException(..), Warning(..), decodeHelper_, decodeHelper)
import Text.Libyaml hiding (decodeFile)
import qualified Text.Libyaml as Y

import           Control.Exception.Safe
import qualified Streamly.Prelude     as S
import           Streamly.Prelude (SerialT, MonadAsync)

eventsFromFile
    :: (MonadCatch m, MonadAsync m, MonadMask m)
    => FilePath
    -> SerialT m Event
eventsFromFile :: FilePath -> SerialT m Event
eventsFromFile = [FilePath] -> FilePath -> SerialT m Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
[FilePath] -> FilePath -> SerialT m Event
go []
  where
-- decodeFile :: (MonadCatch m, MonadAsync m, MonadMask m) => FilePath -> SerialT m Event
    go :: (MonadCatch m, MonadAsync m, MonadMask m) => [FilePath] -> FilePath -> SerialT m Event
    go :: [FilePath] -> FilePath -> SerialT m Event
go [FilePath]
seen FilePath
fp = do
        FilePath
cfp <- IO FilePath -> SerialT m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> SerialT m FilePath)
-> IO FilePath -> SerialT m FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath -> IO FilePath
forall a. a -> a
handleNotFound (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
fp
        Bool -> SerialT m () -> SerialT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
cfp FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
seen) (SerialT m () -> SerialT m ()) -> SerialT m () -> SerialT m ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> SerialT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SerialT m ()) -> IO () -> SerialT m ()
forall a b. (a -> b) -> a -> b
$ ParseException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ParseException
CyclicIncludes
        FilePath -> SerialT m Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
FilePath -> SerialT m Event
Y.decodeFile FilePath
cfp SerialT m Event -> (Event -> SerialT m Event) -> SerialT m Event
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Event
event -> case Event
event of
                EventScalar ByteString
f (UriTag FilePath
"!include") Style
_ Anchor
_ -> do
                    let includeFile :: FilePath
includeFile = FilePath -> FilePath
takeDirectory FilePath
cfp FilePath -> FilePath -> FilePath
</> Text -> FilePath
unpack (ByteString -> Text
decodeUtf8 ByteString
f)
                    (Event -> Bool) -> SerialT m Event -> SerialT m Event
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> Bool) -> t m a -> t m a
S.filter (Event -> [Event] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Event]
irrelevantEvents) (SerialT m Event -> SerialT m Event)
-> SerialT m Event -> SerialT m Event
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath -> SerialT m Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
[FilePath] -> FilePath -> SerialT m Event
go (FilePath
cfp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
seen) FilePath
includeFile
                Event
_ -> Event -> SerialT m Event
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event
event

    irrelevantEvents :: [Event]
irrelevantEvents = [Event
EventStreamStart, Event
EventDocumentStart, Event
EventDocumentEnd, Event
EventStreamEnd]

#if !MIN_VERSION_directory(1, 2, 3)
    handleNotFound = handleJust
        (\e -> do
            guard (isDoesNotExistError e)
            guard (ioeGetLocation e == "canonicalizePath")
            ioeGetFileName e)
        (throwIO . YamlException . ("Yaml file not found: " ++))
#else
    handleNotFound :: a -> a
handleNotFound = a -> a
forall a. a -> a
id
#endif

-- | Like `Data.Yaml.decodeFile` but with support for relative and absolute
-- includes.
--
-- The syntax for includes follows the form:
--
-- > somekey: !include ./somefile.yaml
decodeFile
    :: FromJSON a
    => FilePath
    -> IO (Maybe a)
decodeFile :: FilePath -> IO (Maybe a)
decodeFile FilePath
fp = ((([Warning], Either FilePath (Maybe a))
 -> Either FilePath (Maybe a))
-> Either ParseException ([Warning], Either FilePath (Maybe a))
-> Either ParseException (Either FilePath (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Warning], Either FilePath (Maybe a)) -> Either FilePath (Maybe a)
forall a b. (a, b) -> b
snd (Either ParseException ([Warning], Either FilePath (Maybe a))
 -> Either ParseException (Either FilePath (Maybe a)))
-> IO
     (Either ParseException ([Warning], Either FilePath (Maybe a)))
-> IO (Either ParseException (Either FilePath (Maybe a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SerialT IO Event
-> IO
     (Either ParseException ([Warning], Either FilePath (Maybe a)))
forall a.
FromJSON a =>
SerialT IO Event
-> IO (Either ParseException ([Warning], Either FilePath a))
decodeHelper (FilePath -> SerialT IO Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
FilePath -> SerialT m Event
eventsFromFile FilePath
fp)) IO (Either ParseException (Either FilePath (Maybe a)))
-> (Either ParseException (Either FilePath (Maybe a))
    -> IO (Maybe a))
-> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseException -> IO (Maybe a))
-> (Either FilePath (Maybe a) -> IO (Maybe a))
-> Either ParseException (Either FilePath (Maybe a))
-> IO (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> IO (Maybe a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a))
-> (Either FilePath (Maybe a) -> Maybe a)
-> Either FilePath (Maybe a)
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Maybe a)
-> (Maybe a -> Maybe a) -> Either FilePath (Maybe a) -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> FilePath -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) Maybe a -> Maybe a
forall a. a -> a
id)

-- | Like `Data.Yaml.decodeFileEither` but with support for relative and
-- absolute includes.
--
-- The syntax for includes follows the form:
--
-- > somekey: !include ./somefile.yaml
decodeFileEither
    :: FromJSON a
    => FilePath
    -> IO (Either ParseException a)
decodeFileEither :: FilePath -> IO (Either ParseException a)
decodeFileEither = (Either ParseException ([Warning], a) -> Either ParseException a)
-> IO (Either ParseException ([Warning], a))
-> IO (Either ParseException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([Warning], a) -> a)
-> Either ParseException ([Warning], a) -> Either ParseException a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Warning], a) -> a
forall a b. (a, b) -> b
snd) (IO (Either ParseException ([Warning], a))
 -> IO (Either ParseException a))
-> (FilePath -> IO (Either ParseException ([Warning], a)))
-> FilePath
-> IO (Either ParseException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Either ParseException ([Warning], a))
forall a.
FromJSON a =>
FilePath -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings

-- | A version of `decodeFileEither` that returns warnings along with the parse
-- result.
--
-- @since 0.10.0
decodeFileWithWarnings
    :: FromJSON a
    => FilePath
    -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings :: FilePath -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings = SerialT IO Event -> IO (Either ParseException ([Warning], a))
forall a.
FromJSON a =>
SerialT IO Event -> IO (Either ParseException ([Warning], a))
decodeHelper_ (SerialT IO Event -> IO (Either ParseException ([Warning], a)))
-> (FilePath -> SerialT IO Event)
-> FilePath
-> IO (Either ParseException ([Warning], a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> SerialT IO Event
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
FilePath -> SerialT m Event
eventsFromFile