{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# 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.Aeson.KeyMap
import Data.Aeson.Key
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import System.Directory
import System.FilePath

-- Exception is thrown if the files changed while we were
-- reading them.
data ModifiedWhileReading = ModifiedWhileReading FilePath
    deriving (Int -> ModifiedWhileReading -> ShowS
[ModifiedWhileReading] -> ShowS
ModifiedWhileReading -> String
(Int -> ModifiedWhileReading -> ShowS)
-> (ModifiedWhileReading -> String)
-> ([ModifiedWhileReading] -> ShowS)
-> Show ModifiedWhileReading
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModifiedWhileReading] -> ShowS
$cshowList :: [ModifiedWhileReading] -> ShowS
show :: ModifiedWhileReading -> String
$cshow :: ModifiedWhileReading -> String
showsPrec :: Int -> ModifiedWhileReading -> ShowS
$cshowsPrec :: Int -> ModifiedWhileReading -> ShowS
Show)

instance Exception ModifiedWhileReading

-- Exception thrown if no rule was specified for a given file.
data NoRuleFor = NoRuleFor FilePath
    deriving Int -> NoRuleFor -> ShowS
[NoRuleFor] -> ShowS
NoRuleFor -> String
(Int -> NoRuleFor -> ShowS)
-> (NoRuleFor -> String)
-> ([NoRuleFor] -> ShowS)
-> Show NoRuleFor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoRuleFor] -> ShowS
$cshowList :: [NoRuleFor] -> ShowS
show :: NoRuleFor -> String
$cshow :: NoRuleFor -> String
showsPrec :: Int -> NoRuleFor -> ShowS
$cshowsPrec :: Int -> NoRuleFor -> ShowS
Show

instance Exception NoRuleFor

-- | How to interpret a file.
data Rule = Rule
    { Rule -> String -> Bool
predicate :: FilePath -> Bool
        -- ^ A predicate to see if this rule applies.
    , Rule -> String -> Key
jsonKey   :: FilePath -> Key
        -- ^ A function to transform the filename into a JSON key value
    , Rule -> String -> IO (IResult 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
jsonRule = Rule :: (String -> Bool)
-> (String -> Key) -> (String -> IO (IResult Value)) -> Rule
Rule
    { predicate :: String -> Bool
predicate = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".json"
    , jsonKey :: String -> Key
jsonKey   = String -> Key
Data.Aeson.Key.fromString (String -> Key) -> ShowS -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeBaseName
    , parser :: String -> IO (IResult Value)
parser    = String -> IO (IResult Value)
forall a. FromJSON a => String -> IO (IResult a)
idecodeFileStrict
    }

-- | A rule that reads any file into a JSON string.
textRule :: Rule
textRule :: Rule
textRule = Rule :: (String -> Bool)
-> (String -> Key) -> (String -> IO (IResult Value)) -> Rule
Rule
    { predicate :: String -> Bool
predicate = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True
    , jsonKey :: String -> Key
jsonKey   = String -> Key
Data.Aeson.Key.fromString (String -> Key) -> ShowS -> String -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeFileName
    , parser :: String -> IO (IResult Value)
parser    = (Text -> IResult Value) -> IO Text -> IO (IResult Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> IResult Value
forall a. a -> IResult a
ISuccess (Value -> IResult Value)
-> (Text -> Value) -> Text -> IResult Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String) (IO Text -> IO (IResult Value))
-> (String -> IO Text) -> String -> IO (IResult Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
Text.readFile
    }

-- | Some sane default rules. Attempts do do @`jsonRule`@ and falls back to
-- @`textRule`@
defaultRules :: [Rule]
defaultRules :: [Rule]
defaultRules = [Rule
jsonRule, Rule
textRule]

data EntryType
    = Directory
    | File (FilePath -> IO (IResult Value))

pathType :: [Rule] -> FilePath -> IO (Key, EntryType)
pathType :: [Rule] -> String -> IO (Key, EntryType)
pathType [Rule]
rules String
p = do
    String -> IO Bool
doesDirectoryExist String
p IO Bool -> (Bool -> IO (Key, EntryType)) -> IO (Key, EntryType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> (Key, EntryType) -> IO (Key, EntryType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Key
Data.Aeson.Key.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
p, EntryType
Directory)
        Bool
False -> case (Rule -> Bool) -> [Rule] -> Maybe Rule
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Rule
r -> Rule -> String -> Bool
predicate Rule
r String
p) [Rule]
rules of
            Maybe Rule
Nothing   -> NoRuleFor -> IO (Key, EntryType)
forall e a. Exception e => e -> IO a
throwIO (NoRuleFor -> IO (Key, EntryType))
-> NoRuleFor -> IO (Key, EntryType)
forall a b. (a -> b) -> a -> b
$ String -> NoRuleFor
NoRuleFor String
p
            Just Rule
rule -> (Key, EntryType) -> IO (Key, EntryType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule -> String -> Key
jsonKey Rule
rule String
p, (String -> IO (IResult Value)) -> EntryType
File (Rule -> String -> IO (IResult Value)
parser Rule
rule))

decodeDirectoryValue :: MonadIO io => [Rule] -> FilePath -> io (IResult Value)
decodeDirectoryValue :: forall (io :: * -> *).
MonadIO io =>
[Rule] -> String -> io (IResult Value)
decodeDirectoryValue [Rule]
rules String
path = IO (IResult Value) -> io (IResult Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IResult Value) -> io (IResult Value))
-> IO (IResult Value) -> io (IResult Value)
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
time <- String -> IO UTCTime
getModificationTime String
path
    [String]
ents <- String -> IO [String]
listDirectory String
path
    [(Key, IResult Value)]
kvs <- [Maybe (Key, IResult Value)] -> [(Key, IResult Value)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Key, IResult Value)] -> [(Key, IResult Value)])
-> IO [Maybe (Key, IResult Value)] -> IO [(Key, IResult Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> (String -> IO (Maybe (Key, IResult Value)))
-> IO [Maybe (Key, IResult Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
ents \String
ent -> do
        if String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ent
        then Maybe (Key, IResult Value) -> IO (Maybe (Key, IResult Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Key, IResult Value)
forall a. Maybe a
Nothing
        else (Key, IResult Value) -> Maybe (Key, IResult Value)
forall a. a -> Maybe a
Just ((Key, IResult Value) -> Maybe (Key, IResult Value))
-> IO (Key, IResult Value) -> IO (Maybe (Key, IResult Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
            let path' :: String
path' = String
path String -> ShowS
</> String
ent
            [Rule] -> String -> IO (Key, EntryType)
pathType [Rule]
rules String
path' IO (Key, EntryType)
-> ((Key, EntryType) -> IO (Key, IResult Value))
-> IO (Key, IResult Value)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                (Key
n, EntryType
Directory) -> (Key
n,) (IResult Value -> (Key, IResult Value))
-> (IResult Value -> IResult Value)
-> IResult Value
-> (Key, IResult Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> IResult Value -> IResult Value
forall a. Key -> IResult a -> IResult a
addContext Key
n (IResult Value -> (Key, IResult Value))
-> IO (IResult Value) -> IO (Key, IResult Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rule] -> String -> IO (IResult Value)
forall (io :: * -> *).
MonadIO io =>
[Rule] -> String -> io (IResult Value)
decodeDirectoryValue [Rule]
rules String
path'
                (Key
n, File String -> IO (IResult Value)
parser) -> (Key
n,) (IResult Value -> (Key, IResult Value))
-> (IResult Value -> IResult Value)
-> IResult Value
-> (Key, IResult Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> IResult Value -> IResult Value
forall a. Key -> IResult a -> IResult a
addContext Key
n (IResult Value -> (Key, IResult Value))
-> IO (IResult Value) -> IO (Key, IResult Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (IResult Value)
parser String
path'
    UTCTime
time2 <- String -> IO UTCTime
getModificationTime String
path
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UTCTime
time UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
time2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ModifiedWhileReading -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> ModifiedWhileReading
ModifiedWhileReading String
path)
    IResult Value -> IO (IResult Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IResult Value -> IO (IResult Value))
-> IResult Value -> IO (IResult Value)
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> IResult Object -> IResult Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap (IResult Value) -> IResult Object
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([(Key, IResult Value)] -> KeyMap (IResult Value)
forall v. [(Key, v)] -> KeyMap v
Data.Aeson.KeyMap.fromList [(Key, IResult Value)]
kvs)

addContext :: Key -> IResult a -> IResult a
addContext :: forall a. Key -> IResult a -> IResult a
addContext Key
c (IError JSONPath
p String
s) = JSONPath -> String -> IResult a
forall a. JSONPath -> String -> IResult a
IError (Key -> JSONPathElement
Key Key
c JSONPathElement -> JSONPath -> JSONPath
forall a. a -> [a] -> [a]
: JSONPath
p) String
s
addContext Key
_ IResult a
x = IResult a
x

idecodeFileStrict :: (FromJSON a) => FilePath -> IO (IResult a)
idecodeFileStrict :: forall a. FromJSON a => String -> IO (IResult a)
idecodeFileStrict =
    (ByteString -> IResult a) -> IO ByteString -> IO (IResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either (JSONPath, String) a -> IResult a
forall {a}. Either (JSONPath, String) a -> IResult a
toIResult (Either (JSONPath, String) a -> IResult a)
-> (ByteString -> Either (JSONPath, String) a)
-> ByteString
-> IResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
forall a.
Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
eitherDecodeStrictWith Parser Value
jsonEOF Value -> IResult a
forall a. FromJSON a => Value -> IResult a
ifromJSON) (IO ByteString -> IO (IResult a))
-> (String -> IO ByteString) -> String -> IO (IResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile
  where
    toIResult :: Either (JSONPath, String) a -> IResult a
toIResult (Left (JSONPath
p, String
s)) = JSONPath -> String -> IResult a
forall a. JSONPath -> String -> IResult a
IError JSONPath
p String
s
    toIResult (Right a
a) = a -> IResult a
forall a. a -> IResult a
ISuccess a
a

idecodeStrict :: (FromJSON a) => BS.ByteString -> IResult a
idecodeStrict :: forall a. FromJSON a => ByteString -> IResult a
idecodeStrict = Either (JSONPath, String) a -> IResult a
forall {a}. Either (JSONPath, String) a -> IResult a
toIResult (Either (JSONPath, String) a -> IResult a)
-> (ByteString -> Either (JSONPath, String) a)
-> ByteString
-> IResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
forall a.
Parser Value
-> (Value -> IResult a)
-> ByteString
-> Either (JSONPath, String) a
eitherDecodeStrictWith Parser Value
jsonEOF Value -> IResult a
forall a. FromJSON a => Value -> IResult a
ifromJSON
  where
    toIResult :: Either (JSONPath, String) a -> IResult a
toIResult (Left (JSONPath
p, String
s)) = JSONPath -> String -> IResult a
forall a. JSONPath -> String -> IResult a
IError JSONPath
p String
s
    toIResult (Right a
a) = a -> IResult a
forall a. a -> IResult a
ISuccess a
a

resultToEither :: IResult a -> Either String a
resultToEither :: forall a. IResult a -> Either String a
resultToEither (ISuccess a
a) = a -> Either String a
forall a b. b -> Either a b
Right a
a
resultToEither (IError JSONPath
p String
s) = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ JSONPath -> ShowS
formatError JSONPath
p String
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.
--
-- * Directories are recursed into.
-- * Files ending in @.json@ are decoded as JSON values.
-- * Everything else is assumed to be a valid unicode string.
--
-- 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 :: forall a (io :: * -> *).
(FromJSON a, MonadIO io) =>
String -> io (Either String a)
decodeDirectory = [Rule] -> String -> io (Either String a)
forall a (io :: * -> *).
(FromJSON a, MonadIO io) =>
[Rule] -> String -> io (Either String a)
decodeDirectory' [Rule]
defaultRules

-- | Like @`decodeDirectory`@ but you get to specify the rules.
decodeDirectory' :: (FromJSON a, MonadIO io) => [Rule] -> FilePath -> io (Either String a)
decodeDirectory' :: forall a (io :: * -> *).
(FromJSON a, MonadIO io) =>
[Rule] -> String -> io (Either String a)
decodeDirectory' [Rule]
rules String
p = do
    IResult Value
ev <- [Rule] -> String -> io (IResult Value)
forall (io :: * -> *).
MonadIO io =>
[Rule] -> String -> io (IResult Value)
decodeDirectoryValue [Rule]
rules String
p
    Either String a -> io (Either String a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> io (Either String a))
-> (IResult a -> Either String a)
-> IResult a
-> io (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IResult a -> Either String a
forall a. IResult a -> Either String a
resultToEither (IResult a -> io (Either String a))
-> IResult a -> io (Either String a)
forall a b. (a -> b) -> a -> b
$ do
        Value
v <- IResult Value
ev
        Value -> IResult a
forall a. FromJSON a => Value -> IResult a
ifromJSON Value
v