<commit_before>{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}
module PuppetDB.TestDB (loadTestDB,initTestDB) where

-- import Data.Aeson
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 Control.Exception
import Control.Concurrent.STM
import Data.Monoid
import Control.Applicative
import Data.List (foldl')
import Text.Parsec.Pos
import Data.CaseInsensitive
import Debug.Trace
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS

import Puppet.Parser.Types
import Puppet.Interpreter.Types
import Puppet.Interpreter.Resolve
import Puppet.PP hiding ((<$>))

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)]

-- | Initializes the test DB using a file to back its content
loadTestDB :: FilePath -> IO (S.Either Doc PuppetDBAPI)
loadTestDB fp =
    decodeFileEither fp >>= \case
        Left (OtherParseException rr) -> return (S.Left (string (show rr)))
        Left rr -> trace ("Warning: could not decode " ++ fp ++ " :" ++ show rr) (S.Right <$> genDBAPI (newDB & backingFile ?~ fp ))
        Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp ))


initTestDB :: IO PuppetDBAPI
initTestDB = genDBAPI newDB

newDB :: DBContent
newDB = DBContent mempty mempty Nothing

genDBAPI :: DBContent -> IO PuppetDBAPI
genDBAPI db = do
    d <- newTVarIO db<commit_msg>Workaround yaml limitation for decoding T.Text<commit_after>{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}
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 Control.Exception
import Control.Concurrent.STM
import Data.Monoid
import Control.Applicative
import Data.List (foldl')
import Text.Parsec.Pos
import Data.CaseInsensitive
import Debug.Trace
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS

import Puppet.Parser.Types
import Puppet.Interpreter.Types
import Puppet.Interpreter.Resolve
import Puppet.PP hiding ((<$>))

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) = do
        let toText :: Value -> Parser T.Text
            toText (String m) = pure m
            toText (Number n) = pure (T.pack (show n))
            toText x = fail ("Could not convert " ++ show x ++ " to a string when parsing facts")
        fcts <- v .: "facts" >>= traverse (traverse toText)
        DBContent <$> v .: "resources" <*> pure fcts <*> pure Nothing
    parseJSON _ = mempty

instance ToJSON DBContent where
    toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)]

-- | Initializes the test DB using a file to back its content
loadTestDB :: FilePath -> IO (S.Either Doc PuppetDBAPI)
loadTestDB fp =
    decodeFileEither fp >>= \case
        Left (OtherParseException rr) -> return (S.Left (string (show rr)))
        Left rr -> trace ("Warning: could not decode " ++ fp ++ " :" ++ show rr) (S.Right <$> genDBAPI (newDB & backingFile ?~ fp ))
        Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp ))


initTestDB :: IO PuppetDBAPI
initTestDB = genDBAPI newDB

newDB :: DBContent
newDB = DBContent mempty mempty Nothing

genDBAPI :: DBContent -> IO PuppetDBAPI
genDBAPI db = do
    d <- newTVarIO db
{'fraction_non_alphanumeric': 0.09362502940484592, 'fraction_numerical': 0.0, 'mean_word_length': 3.321138211382114, 'pattern_counts': {'":': 0, '<': 16, '<?xml version=': 0, '>': 30, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6372301', 'n_tokens_mistral': 1290, 'n_tokens_neox': 1271, 'n_words': 426}