diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for json-directory +## 0.1.0.1 -- 2020-06-02 + +* Add rules engine to specify how to interpret a file + ## 0.1.0.0 -- 2019-12-17 * Initial version diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,10 +2,15 @@ entries become keys in a map, and the values are sourced from the contets of each entry. +By default + * Directories are recured into * Files ending with `.json` are read as JSON values * Everything else is interpreted as a string +However, these can be modified with rules, that allow for interpreting +any sort of file as JSON. + The [example](./example) directory in this repository would result in the following JSON value. @@ -22,3 +27,29 @@ } } ``` + +## `jsondir` + +This package also includes an executable for turning directories into JSON +blobs. + +``` +jsondir [--help] [--rule ...] + [--[no-]default{s,-json,-text}] ... + + Turn a directory structure into a JSON value + + --rule Filter the contents of files with the given + SUFFIX with FILTER. The default rules use .json + files as is, and treat everything else as strings. + Can be specified multiple times. Rule are tried in + the order specified. + --[no-]defaults Enable or disable the default rules. Default on. + --[no-]default-json Enable or disable the .json file rule + --[no-]default-text Enable or disable the raw file to JSON string rule. + Directory root to turn into a JSON value + + EXAMPLE + jsondir --rule '.yml' yaml2json ./my-dir +``` + diff --git a/json-directory.cabal b/json-directory.cabal --- a/json-directory.cabal +++ b/json-directory.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: json-directory -version: 0.1.0.0 +version: 0.1.0.1 category: Codec synopsis: Load JSON from files in a directory structure description: Load JSON from files in a directory structure. The object @@ -22,12 +22,12 @@ library exposed-modules: Data.JSON.Directory - build-depends: base ^>=4.12.0.0, aeson, directory, filepath, text, unordered-containers + build-depends: base ^>=4.12.0.0, aeson, bytestring, directory, filepath, text, unordered-containers hs-source-dirs: src default-language: Haskell2010 executable jsondir - build-depends: base ^>=4.12.0.0, json-directory, bytestring, aeson + build-depends: base ^>=4.12.0.0, json-directory, bytestring, aeson, process, filepath, text, mtl hs-source-dirs: jsondir default-language: Haskell2010 main-is: Main.hs diff --git a/jsondir/Main.hs b/jsondir/Main.hs --- a/jsondir/Main.hs +++ b/jsondir/Main.hs @@ -3,17 +3,100 @@ {-# LANGUAGE BlockArguments #-} module Main where -import Data.Aeson +import Control.Exception import Control.Monad -import System.Environment +import Control.Monad.Writer +import Control.Monad.Except +import Data.Aeson +import Data.Foldable import Data.JSON.Directory +import Data.List (isSuffixOf) +import Data.Maybe (isNothing) +import System.Environment +import System.Exit +import System.IO +import System.FilePath +import System.Process +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Text as Text +parseArgs :: Bool -> Bool -> [String] -> ExceptT (Maybe String) (Writer [Rule]) [FilePath] +parseArgs b c ("--rule":rest) = case rest of + pat:filter:rest -> do + let + rule = Rule + { predicate = isSuffixOf pat + , jsonKey = Text.pack . takeBaseName + , parser = + let + parse fp = do + s <- readFile fp + r <- readCreateProcess (shell filter) s + pure $ idecodeStrict (BS.pack r) + handleFailure :: IOError -> IO (IResult Value) + handleFailure = pure . IError [] . displayException + in + \fp -> catch (parse fp) handleFailure + } + tell [rule] + parseArgs b c rest + _ -> throwError $ Just "Invalid argument. Expected `--rule `" +parseArgs b c ("--no-default-json":rest) = parseArgs False c rest +parseArgs b c ("--default-json":rest) = parseArgs True c rest +parseArgs b c ("--no-default-text":rest) = parseArgs b False rest +parseArgs b c ("--default-text":rest) = parseArgs b True rest +parseArgs b c ("--no-defaults":rest) = parseArgs False False rest +parseArgs _ _ ("--help":_) = throwError Nothing +parseArgs b c ("--":rest) = do + when b (tell [jsonRule]) + when c (tell [textRule]) + pure rest +parseArgs b c (a:as) = (a:) <$> parseArgs b c as +parseArgs b c [] = do + when b (tell [jsonRule]) + when c (tell [textRule]) + pure [] + +usage :: String +usage = "\ +\jsondir [--help] [--rule ...]\n\ +\ [--[no-]default{s,-json,-text}] ...\n\ +\\n\ +\ Turn a directory structure into a JSON value\n\ +\\n\ +\ --rule Filter the contents of files with the given\n\ +\ SUFFIX with FILTER. The default rules use .json\n\ +\ files as is, and treat everything else as strings.\n\ +\ Can be specified multiple times. Rule are tried in\n\ +\ the order specified.\n\ +\ --[no-]defaults Enable or disable the default rules. Default on.\n\ +\ --[no-]default-json Enable or disable the .json file rule\n\ +\ --[no-]default-text Enable or disable the raw file to JSON string rule.\n\ +\ Directory root to turn into a JSON value\n\ +\\n\ +\ EXAMPLE\n\ +\ jsondir --rule '.yml' yaml2json ./my-dir\n\ +\" + main :: IO () main = do - as <- getArgs - forM_ as \a -> do - decodeDirectory @Value a >>= \case - Left e -> error e - Right v -> B.putStrLn $ encode v + (eRoots, rules) <- runWriter . runExceptT . parseArgs True True <$> getArgs + + case eRoots of + Left err -> do + traverse_ (hPutStrLn stderr) err + if isNothing err + then putStrLn usage + else do + hPutStrLn stderr "Usage:" + hPutStrLn stderr usage + exitFailure + Right roots -> do + forM_ roots \a -> do + decodeDirectory' @Value rules a >>= \case + Left e -> do + hPutStrLn stderr $ "Error: " ++ e + exitFailure + Right v -> B.putStrLn $ encode v diff --git a/src/Data/JSON/Directory.hs b/src/Data/JSON/Directory.hs --- a/src/Data/JSON/Directory.hs +++ b/src/Data/JSON/Directory.hs @@ -3,13 +3,25 @@ {-# LANGUAGE BlockArguments #-} module Data.JSON.Directory ( decodeDirectory + , decodeDirectory' + , Rule(..) + , IResult(..) + , defaultRules + , jsonRule + , textRule + , idecodeStrict , ModifiedWhileReading + , NoRuleFor ) where import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Aeson +import Data.Aeson.Internal (IResult(..), formatError, ifromJSON) +import Data.Aeson.Parser.Internal (eitherDecodeStrictWith, jsonEOF) +import Data.Aeson.Types +import qualified Data.ByteString as BS import Data.HashMap.Strict import Data.List import Data.Maybe @@ -19,26 +31,65 @@ import System.Directory import System.FilePath +-- Exception is thrown if the files changed while we were +-- reading them. data ModifiedWhileReading = ModifiedWhileReading FilePath deriving (Show) instance Exception ModifiedWhileReading +-- Exception thrown if no rule was specified for a given file. +data NoRuleFor = NoRuleFor FilePath + deriving Show + +instance Exception NoRuleFor + +-- | How to interpret a file. +data Rule = Rule + { predicate :: FilePath -> Bool + -- ^ A predicate to see if this rule applies. + , jsonKey :: FilePath -> Text + -- ^ A function to transform the filename into a JSON key value + , parser :: FilePath -> IO (IResult Value) + -- ^ Turn a file into a Value. The @JSONPath@ in the @IResult@ will be + -- merged into the correct location. + } + +-- | A rule that reads @.json@ files as JSON. +jsonRule :: Rule +jsonRule = Rule + { predicate = isSuffixOf ".json" + , jsonKey = Text.pack . takeBaseName + , parser = idecodeFileStrict + } + +-- | A rule that reads any file into a JSON string. +textRule :: Rule +textRule = Rule + { predicate = const True + , jsonKey = Text.pack . takeFileName + , parser = fmap (ISuccess . String) . Text.readFile + } + +-- | Some sane default rules. Attempts do do @`jsonRule`@ and falls back to +-- @`textRule`@ +defaultRules :: [Rule] +defaultRules = [jsonRule, textRule] + data EntryType = Directory - | JSON - | TextFile + | File (FilePath -> IO (IResult Value)) -pathType :: FilePath -> IO (Text, EntryType) -pathType p = do +pathType :: [Rule] -> FilePath -> IO (Text, EntryType) +pathType rules p = do doesDirectoryExist p >>= \case True -> pure (Text.pack $ takeFileName p, Directory) - False -> pure case splitExtension (takeFileName p) of - (name, ".json") -> (Text.pack $ name, JSON) - _ -> (Text.pack $ takeFileName p, TextFile) + False -> case find (\r -> predicate r p) rules of + Nothing -> throwIO $ NoRuleFor p + Just rule -> pure (jsonKey rule p, File (parser rule)) -decodeDirectoryValue :: MonadIO io => FilePath -> io (Either String Value) -decodeDirectoryValue path = liftIO $ do +decodeDirectoryValue :: MonadIO io => [Rule] -> FilePath -> io (IResult Value) +decodeDirectoryValue rules path = liftIO $ do time <- getModificationTime path ents <- listDirectory path kvs <- catMaybes <$> forM ents \ent -> do @@ -46,19 +97,34 @@ then pure Nothing else Just <$> do let path' = path ent - pathType path' >>= \case - (n, Directory) -> (n,) <$> decodeDirectoryValue path' - (n, JSON ) -> (n,) <$> eitherDecodeFileStrict path' - (n, TextFile ) -> (n,) . Right . String <$> Text.readFile path' + pathType rules path' >>= \case + (n, Directory) -> (n,) . addContext n <$> decodeDirectoryValue rules path' + (n, File parser) -> (n,) . addContext n <$> parser path' time2 <- getModificationTime path unless (time == time2) $ throwIO (ModifiedWhileReading path) - pure $ Object <$> sequence (Data.HashMap.Strict.fromList kvs) -resultToEither :: Result a -> Either String a -resultToEither (Success a) = Right a -resultToEither (Error s) = Left s +addContext :: Text -> IResult a -> IResult a +addContext c (IError p s) = IError (Key c : p) s +addContext _ x = x +idecodeFileStrict :: (FromJSON a) => FilePath -> IO (IResult a) +idecodeFileStrict = + fmap (toIResult . eitherDecodeStrictWith jsonEOF ifromJSON) . BS.readFile + where + toIResult (Left (p, s)) = IError p s + toIResult (Right a) = ISuccess a + +idecodeStrict :: (FromJSON a) => BS.ByteString -> IResult a +idecodeStrict = toIResult . eitherDecodeStrictWith jsonEOF ifromJSON + where + toIResult (Left (p, s)) = IError p s + toIResult (Right a) = ISuccess a + +resultToEither :: IResult a -> Either String a +resultToEither (ISuccess a) = Right a +resultToEither (IError p s) = Left $ formatError p s + -- | Takes a directory and decodes it using a @`FromJSON`@ instance. -- Each entry in the directory becomes a key, and the contents become -- the corresponding value. @@ -69,9 +135,15 @@ -- -- This function can throw IO exceptions as well as a @`ModifiedWhileReading`@ -- exception if the modification time changes during processing. +-- +-- Uses @`defaultRules`@ decodeDirectory :: (FromJSON a, MonadIO io) => FilePath -> io (Either String a) -decodeDirectory p = do - ev <- decodeDirectoryValue p - pure $ do +decodeDirectory = decodeDirectory' defaultRules + +-- | Like @`decodeDirectory`@ but you get to specify the rules. +decodeDirectory' :: (FromJSON a, MonadIO io) => [Rule] -> FilePath -> io (Either String a) +decodeDirectory' rules p = do + ev <- decodeDirectoryValue rules p + pure . resultToEither $ do v <- ev - resultToEither $ fromJSON v + ifromJSON v