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