module PuppetDB.TestDB (loadTestDB,initTestDB) where
import Data.Yaml
import qualified Data.Text as T
import qualified Data.Either.Strict as S
import qualified Data.Vector as V
import Control.Lens
import Data.Aeson.Lens
import Control.Exception
import Control.Concurrent.STM
import Data.Monoid
import Control.Applicative
import Data.List (foldl')
import Text.Parsec.Pos
import Data.CaseInsensitive
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Puppet.Parser.Types
import Puppet.Interpreter.Types
import Puppet.PP hiding ((<$>))
import Puppet.Lens
data DBContent = DBContent { _dbcontentResources :: Container WireCatalog
, _dbcontentFacts :: Container Facts
, _dbcontentBackingFile :: Maybe FilePath
}
makeFields ''DBContent
type DB = TVar DBContent
instance FromJSON DBContent where
parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing
parseJSON _ = mempty
instance ToJSON DBContent where
toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)]
loadTestDB :: FilePath -> IO (S.Either PrettyError (PuppetDBAPI IO))
loadTestDB fp =
decodeFileEither fp >>= \case
Left (OtherParseException rr) -> return (S.Left (PrettyError (string (show rr))))
Left (InvalidYaml Nothing) -> baseError "Unknown error"
Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: "
then newFile
else baseError (string s)
Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c
Left _ -> newFile
Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp ))
where
baseError r = return $ S.Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r
newFile = S.Right <$> genDBAPI (newDB & backingFile ?~ fp )
initTestDB :: IO (PuppetDBAPI IO)
initTestDB = genDBAPI newDB
newDB :: DBContent
newDB = DBContent mempty mempty Nothing
genDBAPI :: DBContent -> IO (PuppetDBAPI IO)
genDBAPI db = do
d <- newTVarIO db
return (PuppetDBAPI (dbapiInfo d)
(replCat d)
(replFacts d)
(deactivate d)
(getFcts d)
(getRes d)
(getNds d)
(commit d)
(getResNode d)
)
data Extracted = EText T.Text
| ESet (HS.HashSet T.Text)
| ENil
resolveQuery :: (a -> b -> Extracted) -> Query a -> (b -> Bool)
resolveQuery _ QEmpty = const True
resolveQuery f (QEqual a t) = \v -> case f a v of
EText tt -> mk tt == mk t
ESet ss -> ss ^. contains t
_ -> False
resolveQuery f (QNot q) = not . resolveQuery f q
resolveQuery f (QG a i) = ncompare (>) f a i
resolveQuery f (QL a i) = ncompare (<) f a i
resolveQuery f (QGE a i) = ncompare (>=) f a i
resolveQuery f (QLE a i) = ncompare (<=) f a i
resolveQuery _ (QMatch _ _) = const False
resolveQuery f (QAnd qs) = \v -> all (\q -> resolveQuery f q v) qs
resolveQuery f (QOr qs) = \v -> any (\q -> resolveQuery f q v) qs
dbapiInfo :: DB -> IO Doc
dbapiInfo db = do
c <- readTVarIO db
case c ^. backingFile of
Nothing -> return "TestDB"
Just v -> return ("TestDB" <+> string v)
ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> (b -> Bool)
ncompare operation f a i v = case f a v of
EText tt -> case PString tt ^? _Integer of
Just ii -> operation i ii
_ -> False
_ -> False
mustWork :: IO () -> IO (S.Either PrettyError ())
mustWork a = a >> return (S.Right ())
replCat :: DB -> WireCatalog -> IO (S.Either PrettyError ())
replCat db wc = mustWork $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc)
replFacts :: DB -> [(Nodename, Facts)] -> IO (S.Either PrettyError ())
replFacts db lst = mustWork $ atomically $ modifyTVar db $
facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)
deactivate :: DB -> Nodename -> IO (S.Either PrettyError ())
deactivate db n = mustWork $ atomically $ modifyTVar db $
(resources . at n .~ Nothing) . (facts . at n .~ Nothing)
getFcts :: DB -> Query FactField -> IO (S.Either PrettyError [PFactInfo])
getFcts db f = fmap (S.Right . filter (resolveQuery factQuery f) . toFactInfo) (readTVarIO db)
where
toFactInfo :: DBContent -> [PFactInfo]
toFactInfo = concatMap gf . HM.toList . _dbcontentFacts
where
gf (k,n) = do
(fn,fv) <- HM.toList n
return $ PFactInfo k fn fv
factQuery :: FactField -> PFactInfo -> Extracted
factQuery t = EText . view l
where
l = case t of
FName -> factname
FValue -> factval . _PString
FCertname -> nodename
resourceQuery :: ResourceField -> Resource -> Extracted
resourceQuery RTag r = r ^. rtags . to ESet
resourceQuery RCertname r = r ^. rnode . to EText
resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of
Just s -> EText s
Nothing -> ENil
resourceQuery RType r = r ^. rid . itype . to EText
resourceQuery RTitle r = r ^. rid . iname . to EText
resourceQuery RExported r = if r ^. rvirtuality == Exported
then EText "true"
else EText "false"
resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText
resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText
getRes :: DB -> Query ResourceField -> IO (S.Either PrettyError [Resource])
getRes db f = fmap (S.Right . filter (resolveQuery resourceQuery f) . toResources) (readTVarIO db)
where
toResources :: DBContent -> [Resource]
toResources = concatMap (V.toList . view wResources) . HM.elems . view resources
getResNode :: DB -> Nodename -> Query ResourceField -> IO (S.Either PrettyError [Resource])
getResNode db nn f = do
c <- readTVarIO db
return $ case c ^. resources . at nn of
Just cnt -> S.Right $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources
Nothing -> S.Left "Unknown node"
commit :: DB -> IO (S.Either PrettyError ())
commit db = do
dbc <- atomically $ readTVar db
case dbc ^. backingFile of
Nothing -> return (S.Left "No backing file defined")
Just bf -> fmap S.Right (encodeFile bf dbc) `catches` [ ]
getNds :: DB -> Query NodeField -> IO (S.Either PrettyError [PNodeInfo])
getNds _ _ = return (S.Left "getNds not implemented")