module Store.Config
( Path(..)
, pathKey
, keyPath
, Value(..)
, ConfigMap
, Config
, configMap
, configPath
, load
, Configurable(..)
, (!)
) where
import Prelude hiding (lookup)
import Control.Applicative ((<|>))
import Control.Arrow (first)
import Control.Exception (Exception, throw)
import Control.Monad ((<=<))
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Foldable (fold)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (IsString(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable, TypeRep, typeRep)
import qualified Data.Vector as V
import qualified Text.Parsec as P
import qualified Text.Parsec.ByteString.Lazy as P
import qualified Text.Parsec.Token as PT
import JSON ()
import Ops
type Key = BS.ByteString
newtype Path = Path { pathList :: [Key] } deriving (Monoid)
pathKey :: Path -> Key
pathKey (Path p) = BS.intercalate (BSC.singleton '.') p
keyPath :: Key -> Path
keyPath = Path . BSC.split '.'
pathSnoc :: Path -> Key -> Path
pathSnoc (Path l) k = Path (l ++ [k])
instance Show Path where
showsPrec p = showsPrec p . pathKey
instance IsString Path where
fromString = keyPath . fromString
data ConfigError
= ParseError P.ParseError
| ConflictError
{ errorPath :: Path
, errorValue1, errorValue2 :: Value
}
| ValueError
{ errorPath :: Path
, errorValue :: Value
, errorNeeded :: TypeRep
}
deriving (Typeable, Show)
instance Exception ConfigError
data Value
= Empty
| Boolean !Bool
| Integer !Integer
| String !BS.ByteString
| List [Value]
| Sub !ConfigMap
deriving (Typeable, Eq, Show)
type ConfigMap = HM.HashMap BS.ByteString Value
data Config = Config
{ configPath :: !Path
, configMap :: !ConfigMap
} deriving (Typeable)
topConfig :: ConfigMap -> Config
topConfig = Config (Path [])
unionValue :: Path -> Value -> Value -> Value
unionValue _ Empty v = v
unionValue _ v Empty = v
unionValue p (Sub m1) (Sub m2) = Sub $ unionConfig p m1 m2
unionValue p v1 v2
| v1 == v2 = v1
| otherwise = throw $ ConflictError{ errorPath = p, errorValue1 = v1, errorValue2 = v2 }
unionConfig :: Path -> ConfigMap -> ConfigMap -> ConfigMap
unionConfig p = HM.foldrWithKey $ \k -> HM.insertWith (flip $ unionValue (pathSnoc p k)) k
instance Monoid Config where
mempty = topConfig HM.empty
Config (Path p1) m1 `mappend` Config (Path p2) m2 = Config p m where
(p', (p1', p2')) = cpfx p1 p2
p = Path p'
m = unionConfig p (nest m1 p1') (nest m2 p2')
cpfx (a:al) (b:bl) | a == b = first (a :) $ cpfx al bl
cpfx al bl = ([], (al, bl))
nest = foldr (\k -> HM.singleton k . Sub)
lookup :: Path -> ConfigMap -> Value
lookup (Path []) m = Sub m
lookup (Path [k]) m | Just v <- HM.lookup k m = v
lookup (Path (k:l)) m | Just (Sub km) <- HM.lookup k m = lookup (Path l) km
lookup _ _ = Empty
parser :: P.Parser ConfigMap
parser = whiteSpace *> block mempty HM.empty <* P.eof where
block p m = (block p =<< pair p m) <|> return m
pair p m = do
ks <- identifier P.<?> "key"
let k = BSC.pack ks
kp = pathSnoc p k
km <- case HM.lookupDefault Empty k m of
Empty -> return Nothing
Sub km -> return $ Just km
_ -> fail $ "Duplicate key value: " ++ show kp
kv <- lexeme dot *> (Sub <$> pair kp (fold km)) <|> rhs kp km
return $ HM.insert k kv m
rhs p Nothing = sub p HM.empty <|>
lexeme (P.char '=') *> val
rhs p (Just m) = sub p m
sub p m = Sub <$> braces (block p m)
val = P.choice
[ Boolean True <$ reserved "true"
, Boolean False <$ reserved "false"
, Integer <$> integer
, String . BSC.pack <$> stringLiteral
, List <$> brackets (commaSep val)
] P.<?> "value"
PT.TokenParser{..} = PT.makeTokenParser PT.LanguageDef
{ PT.commentStart = ""
, PT.commentEnd = ""
, PT.commentLine = "#"
, PT.nestedComments = False
, PT.identStart = P.letter
, PT.identLetter = P.alphaNum <|> P.oneOf "-_"
, PT.opStart = P.unexpected "operator"
, PT.opLetter = P.unexpected "operator"
, PT.reservedNames = []
, PT.reservedOpNames = ["="]
, PT.caseSensitive = True
}
load :: FilePath -> IO Config
load f = either (throw . ParseError) (return . topConfig) =<< P.parseFromFile parser f
class Typeable a => Configurable a where
get :: Path -> Config -> a
get p (Config cp m) = fromMaybe (throw ValueError{ errorPath = cp <> p, errorValue = v, errorNeeded = typeRep r}) r where
v = lookup p m
r = config v
config :: Value -> Maybe a
instance Configurable Value where
get p (Config _ m) = lookup p m
config = Just
instance Configurable ConfigMap where
config (Sub m) = Just m
config Empty = Just HM.empty
config _ = Nothing
instance Configurable Config where
get p c = Config (configPath c <> p) $ get p c
config v = topConfig <$> config v
instance Configurable a => Configurable (Maybe a) where
config Empty = Just Nothing
config v = Just <$> config v
instance Configurable Bool where
config (Boolean b) = Just b
config _ = Nothing
instance Configurable Integer where
config (Integer i) = Just i
config _ = Nothing
instance Configurable BS.ByteString where
config (String s) = Just s
config _ = Nothing
instance Configurable a => Configurable [a] where
config (List l) = mapM config l
config _ = Nothing
instance Configurable T.Text where
config = rightJust . TE.decodeUtf8' <=< config
instance Configurable String where
config v = BSC.unpack <$> config v
configBoundedInt :: forall a . (Integral a, Bounded a) => Value -> Maybe a
configBoundedInt = f <=< config where
f i = (i >= toInteger (minBound :: a) && i <= toInteger (maxBound :: a)) `thenUse` fromInteger i
instance Configurable Int where
config = configBoundedInt
infixl 9 !
(!) :: Configurable a => Config -> Path -> a
(!) = flip get
instance JSON.ToJSON Config where
toJSON = JSON.toJSON . configMap
toEncoding = JSON.toEncoding . configMap
instance JSON.ToJSON Value where
toJSON Empty = JSON.Null
toJSON (Boolean b) = JSON.Bool b
toJSON (String s) = JSON.String $ TE.decodeUtf8 s
toJSON (Integer i) = JSON.Number $ fromInteger i
toJSON (List l) = JSON.Array $ V.fromList $ map JSON.toJSON l
toJSON (Sub c) = JSON.toJSON c
toEncoding (List l) = JSON.foldable l
toEncoding (Sub c) = JSON.toEncoding c
toEncoding v = JSON.toEncoding $ JSON.toJSON v