1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, RecordWildCards #-} 2 module Databrary.Store.Config 3 ( Path(..) 4 , pathKey 5 , keyPath 6 , Value(..) 7 , ConfigMap 8 , Config 9 , configMap 10 , configPath 11 , load 12 , Configurable(..) 13 , (!) 14 ) where 15 16 import Prelude hiding (lookup) 17 18 import Control.Applicative ((<|>)) 19 import Control.Arrow (first) 20 import Control.Exception (Exception, throw) 21 import Control.Monad ((<=<)) 22 import qualified Data.Aeson.Types as JSON 23 import qualified Data.ByteString as BS 24 import qualified Data.ByteString.Char8 as BSC 25 import Data.Foldable (fold) 26 import qualified Data.HashMap.Strict as HM 27 import Data.Maybe (fromMaybe) 28 import Data.Monoid ((<>)) 29 import Data.String (IsString(..)) 30 import qualified Data.Text as T 31 import qualified Data.Text.Encoding as TE 32 import Data.Typeable (Typeable, TypeRep, typeRep) 33 import qualified Data.Vector as V 34 import qualified Text.Parsec as P 35 import qualified Text.Parsec.ByteString.Lazy as P 36 import qualified Text.Parsec.Token as PT 37 38 import Databrary.JSON () 39 import Databrary.Ops 40 41 type Key = BS.ByteString 42 newtype Path = Path { pathList :: [Key] } deriving (Monoid) 43 44 pathKey :: Path -> Key 45 pathKey (Path p) = BS.intercalate (BSC.singleton '.') p 46 47 keyPath :: Key -> Path 48 keyPath = Path . BSC.split '.' 49 50 pathSnoc :: Path -> Key -> Path 51 pathSnoc (Path l) k = Path (l ++ [k]) 52 53 instance Show Path where 54 showsPrec p = showsPrec p . pathKey 55 56 instance IsString Path where 57 fromString = keyPath . fromString 58 59 data ConfigError 60 = ParseError P.ParseError 61 | ConflictError 62 { errorPath :: Path 63 , errorValue1, errorValue2 :: Value 64 } 65 | ValueError 66 { errorPath :: Path 67 , errorValue :: Value 68 , errorNeeded :: TypeRep 69 } 70 deriving (Typeable, Show) 71 72 instance Exception ConfigError 73 74 data Value 75 = Empty 76 | Boolean !Bool 77 | Integer !Integer 78 | String !BS.ByteString 79 | List [Value] 80 | Sub !ConfigMap 81 deriving (Typeable, Eq, Show) 82 83 type ConfigMap = HM.HashMap BS.ByteString Value 84 85 data Config = Config 86 { configPath :: !Path 87 , configMap :: !ConfigMap 88 } deriving (Typeable) -- , Show) 89 90 topConfig :: ConfigMap -> Config 91 topConfig = Config (Path []) 92 93 unionValue :: Path -> Value -> Value -> Value 94 unionValue _ Empty v = v 95 unionValue _ v Empty = v 96 unionValue p (Sub m1) (Sub m2) = Sub $ unionConfig p m1 m2 97 unionValue p v1 v2 98 | v1 == v2 = v1 99 | otherwise = throw $ ConflictError{ errorPath = p, errorValue1 = v1, errorValue2 = v2 } 100 101 unionConfig :: Path -> ConfigMap -> ConfigMap -> ConfigMap 102 unionConfig p = HM.foldrWithKey $ \k -> HM.insertWith (flip $ unionValue (pathSnoc p k)) k 103 104 -- |Merge two configs, throwing 'ConflictError' on conflicts 105 instance Monoid Config where 106 mempty = topConfig HM.empty 107 Config (Path p1) m1 `mappend` Config (Path p2) m2 = Config p m where 108 (p', (p1', p2')) = cpfx p1 p2 109 p = Path p' 110 m = unionConfig p (nest m1 p1') (nest m2 p2') 111 cpfx (a:al) (b:bl) | a == b = first (a :) $ cpfx al bl 112 cpfx al bl = ([], (al, bl)) 113 nest = foldr (\k -> HM.singleton k . Sub) 114 115 lookup :: Path -> ConfigMap -> Value 116 lookup (Path []) m = Sub m 117 lookup (Path [k]) m | Just v <- HM.lookup k m = v 118 lookup (Path (k:l)) m | Just (Sub km) <- HM.lookup k m = lookup (Path l) km 119 lookup _ _ = Empty 120 121 parser :: P.Parser ConfigMap 122 parser = whiteSpace *> block mempty HM.empty <* P.eof where 123 block p m = (block p =<< pair p m) <|> return m 124 pair p m = do 125 ks <- identifier P.<?> "key" 126 let k = BSC.pack ks 127 kp = pathSnoc p k 128 km <- case HM.lookupDefault Empty k m of 129 Empty -> return Nothing 130 Sub km -> return $ Just km 131 _ -> fail $ "Duplicate key value: " ++ show kp 132 kv <- lexeme dot *> (Sub <$> pair kp (fold km)) <|> rhs kp km 133 return $ HM.insert k kv m 134 rhs p Nothing = sub p HM.empty <|> 135 lexeme (P.char '=') *> val 136 rhs p (Just m) = sub p m 137 sub p m = Sub <$> braces (block p m) 138 val = P.choice 139 [ Boolean True <$ reserved "true" 140 , Boolean False <$ reserved "false" 141 , Integer <$> integer 142 , String . BSC.pack <$> stringLiteral 143 , List <$> brackets (commaSep val) 144 ] P.<?> "value" 145 PT.TokenParser{..} = PT.makeTokenParser PT.LanguageDef 146 { PT.commentStart = "" 147 , PT.commentEnd = "" 148 , PT.commentLine = "#" 149 , PT.nestedComments = False 150 , PT.identStart = P.letter 151 , PT.identLetter = (P.alphaNum <|> P.oneOf "-_") 152 , PT.opStart = P.unexpected "operator" 153 , PT.opLetter = P.unexpected "operator" 154 , PT.reservedNames = [] 155 , PT.reservedOpNames = ["="] 156 , PT.caseSensitive = True 157 } 158 159 load :: FilePath -> IO Config 160 load f = either (throw . ParseError) (return . topConfig) =<< P.parseFromFile parser f 161 162 class Typeable a => Configurable a where 163 get :: Path -> Config -> a 164 get p (Config cp m) = fromMaybe (throw ValueError{ errorPath = cp <> p, errorValue = v, errorNeeded = typeRep r}) r where 165 v = lookup p m 166 r = config v 167 config :: Value -> Maybe a 168 169 instance Configurable Value where 170 get p (Config _ m) = lookup p m 171 config = Just 172 173 instance Configurable ConfigMap where 174 config (Sub m) = Just m 175 config Empty = Just HM.empty 176 config _ = Nothing 177 178 instance Configurable Config where 179 get p c = Config (configPath c <> p) $ get p c 180 config v = topConfig <$> config v 181 182 instance Configurable a => Configurable (Maybe a) where 183 config Empty = Just Nothing 184 config v = Just <$> config v 185 186 instance Configurable Bool where 187 config (Boolean b) = Just b 188 config _ = Nothing 189 190 instance Configurable Integer where 191 config (Integer i) = Just i 192 config _ = Nothing 193 194 instance Configurable BS.ByteString where 195 config (String s) = Just s 196 config _ = Nothing 197 198 instance {-# OVERLAPPABLE #-} Configurable a => Configurable [a] where 199 config (List l) = mapM config l 200 config _ = Nothing 201 202 instance Configurable T.Text where 203 config = rightJust . TE.decodeUtf8' <=< config 204 205 instance {-# OVERLAPPING #-} Configurable String where 206 config v = BSC.unpack <$> config v 207 208 configBoundedInt :: forall a . (Integral a, Bounded a) => Value -> Maybe a 209 configBoundedInt = f <=< config where 210 f i = (i >= toInteger (minBound :: a) && i <= toInteger (maxBound :: a)) `thenUse` (fromInteger i) 211 212 instance Configurable Int where 213 config = configBoundedInt 214 215 infixl 9 ! 216 (!) :: Configurable a => Config -> Path -> a 217 (!) = flip get 218 219 instance JSON.ToJSON Config where 220 toJSON = JSON.toJSON . configMap 221 toEncoding = JSON.toEncoding . configMap 222 223 -- instance JSON.ToJSON ConfigMap where 224 -- toJSON = JSON.object . map (TE.decodeUtf8 *** JSON.toJSON) . HM.toList 225 -- toEncoding = JSON.pairs . HM.foldrWithKey (\k v -> (TE.decodeUtf8 k JSON..= v <>)) mempty 226 227 instance JSON.ToJSON Value where 228 toJSON Empty = JSON.Null 229 toJSON (Boolean b) = JSON.Bool b 230 toJSON (String s) = JSON.String $ TE.decodeUtf8 s 231 toJSON (Integer i) = JSON.Number $ fromInteger i 232 toJSON (List l) = JSON.Array $ V.fromList $ map JSON.toJSON l 233 toJSON (Sub c) = JSON.toJSON c 234 toEncoding (List l) = JSON.foldable l 235 toEncoding (Sub c) = JSON.toEncoding c 236 toEncoding v = JSON.toEncoding $ JSON.toJSON v