@@ -0,0 +1,62 @@
1+{-# LANGUAGE RankNTypes #-}
2+module Data.Yaml.Include (decodeFile, decodeFileEither) where
3+
4+import Control.Applicative
5+import Control.Monad (when)
6+import Control.Exception (throwIO)
7+import Control.Monad.IO.Class (liftIO)
8+import Control.Monad.Trans.Resource (MonadResource)
9+import System.Directory
10+import System.FilePath
11+import Data.Text (unpack)
12+import Data.Text.Encoding (decodeUtf8)
13+import Data.Aeson (FromJSON)
14+import Data.Conduit
15+import qualified Data.Conduit.List as CL
16+import Data.Yaml (ParseException(..), decodeHelper)
17+import Text.Libyaml hiding (decodeFile)
18+import qualified Text.Libyaml as Y
19+
20+eventsFromFile
21+ :: MonadResource m
22+ => FilePath
23+ -> Producer m Event
24+eventsFromFile = go []
25+ where
26+ go :: MonadResource m => [FilePath] -> FilePath -> Producer m Event
27+ go seen fp = do
28+ cfp <- liftIO $ canonicalizePath fp
29+ when (cfp `elem` seen) $ do
30+ liftIO $ throwIO CyclicIncludes
31+ Y.decodeFile cfp $= do
32+ awaitForever $ \event -> case event of
33+ EventScalar f (UriTag "!include") _ _ -> do
34+ let includeFile = takeDirectory cfp </> unpack (decodeUtf8 f)
35+ go (cfp : seen) includeFile $= CL.filter (`notElem` irrelevantEvents)
36+ _ -> yield event
37+
38+ irrelevantEvents = [EventStreamStart, EventDocumentStart, EventDocumentEnd, EventStreamEnd]
39+
40+-- | Like `Data.Yaml.decodeFile` but with support for relative and absolute
41+-- includes.
42+--
43+-- The syntax for includes follows the form:
44+--
45+-- > somekey: !include ./somefile.yaml
46+decodeFile
47+ :: FromJSON a
48+ => FilePath
49+ -> IO (Maybe a)
50+decodeFile fp = decodeHelper (eventsFromFile fp) >>= either throwIO (return . either (const Nothing) id)
51+
52+-- | Like `Data.Yaml.decodeFileEither` but with support for relative and
53+-- absolute includes.
54+--
55+-- The syntax for includes follows the form:
56+--
57+-- > somekey: !include ./somefile.yaml
58+decodeFileEither
59+ :: FromJSON a
60+ => FilePath
61+ -> IO (Either ParseException a)
62+decodeFileEither fp = either Left (either (Left . AesonException) Right) <$> decodeHelper (eventsFromFile fp)