{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE TemplateHaskell        #-}

-- | A stub implementation of PuppetDB, backed by a YAML file.
module PuppetDB.TestDB
       ( loadTestDB
       , initTestDB
) where

import           Control.Applicative
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Lens
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Either
import           Data.Aeson.Lens
import           Data.CaseInsensitive
import qualified Data.HashMap.Strict      as HM
import qualified Data.HashSet             as HS
import           Data.List                (foldl')
import qualified Data.Maybe.Strict        as S
import           Data.Monoid
import qualified Data.Text                as T
import qualified Data.Vector              as V
import           Data.Yaml
import           Text.Parsec.Pos
import           Prelude

import           Puppet.Interpreter.Types
import           Puppet.Lens
import           Puppet.Parser.Types
import           Puppet.PP

data DBContent = DBContent
    { _dbcontentResources   :: Container WireCatalog
    , _dbcontentFacts       :: Container Facts
    , _dbcontentBackingFile :: Maybe FilePath
    }

makeLensesWith abbreviatedFields ''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 (Either PrettyError (PuppetDBAPI IO))
loadTestDB fp =
    decodeFileEither fp >>= \case
        Left (OtherParseException rr) -> return (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 Right (genDBAPI (x & backingFile ?~ fp ))
    where
        baseError r = return $ Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r
        newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp )

-- | Starts a new PuppetDB, without any backing file.
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

replCat :: DB -> WireCatalog -> EitherT PrettyError IO ()
replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc)

replFacts :: DB -> [(Nodename, Facts)] -> EitherT PrettyError IO ()
replFacts db lst = liftIO $ atomically $ modifyTVar db $
                    facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)

deactivate :: DB -> Nodename -> EitherT PrettyError IO ()
deactivate db n = liftIO $ atomically $ modifyTVar db $
                    (resources . at n .~ Nothing) . (facts . at n .~ Nothing)

getFcts :: DB -> Query FactField -> EitherT PrettyError IO [PFactInfo]
getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ 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 -> EitherT PrettyError IO [Resource]
getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db)
    where
        toResources :: DBContent -> [Resource]
        toResources = concatMap (V.toList . view wResources) .  HM.elems . view resources

getResNode :: DB -> Nodename -> Query ResourceField -> EitherT PrettyError IO [Resource]
getResNode db nn f = do
    c <- liftIO $ readTVarIO db
    case c ^. resources . at nn of
        Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources
        Nothing -> left "Unknown node"

commit :: DB -> EitherT PrettyError IO ()
commit db = do
    dbc <- liftIO $ atomically $ readTVar db
    case dbc ^. backingFile of
        Nothing -> left "No backing file defined"
        Just bf -> liftIO (encodeFile bf dbc `catches` [ ])

getNds :: DB -> Query NodeField -> EitherT PrettyError IO [PNodeInfo]
getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db)
    where
        toNodeInfo :: DBContent -> [PNodeInfo]
        toNodeInfo = fmap g . HM.keys . _dbcontentFacts
             where
                g :: Nodename -> PNodeInfo
                g = \n -> PNodeInfo n False S.Nothing S.Nothing S.Nothing

getNds _ _ = left "getNds with query not implemented"