Core.hs

{-# LANGUAGE TemplateHaskell #-}

module PuppetDB.Core where

import Control.Lens
import Data.Aeson
import qualified Data.List as List
import Data.Maybe (fromJust)
import qualified Data.Maybe.Strict as S
import Data.Time.Clock
import Facter
import GHC.Read (Read (..))
import Puppet.Language
import Web.HttpApiData (ToHttpApiData (..))
import XPrelude hiding (Read)

-- | The supported PuppetDB implementations.
data PDBType
  = -- | Your standard PuppetDB, queried through the HTTP interface.
    PDBRemote
  | -- | A stupid stub, this is the default choice.
    PDBDummy
  | -- | A slow but handy PuppetDB implementation that is backed by a YAML file.
    PDBTest
  deriving (Eq)

instance Read PDBType where
  readsPrec _ r
    | isJust reml = [(PDBRemote, fromJust reml)]
    | isJust rems = [(PDBRemote, fromJust rems)]
    | isJust duml = [(PDBDummy, fromJust duml)]
    | isJust dums = [(PDBDummy, fromJust dums)]
    | isJust tstl = [(PDBTest, fromJust tstl)]
    | isJust tsts = [(PDBTest, fromJust tsts)]
    | otherwise = []
    where
      reml = List.stripPrefix "PDBRemote" r
      rems = List.stripPrefix "remote" r
      duml = List.stripPrefix "PDBDummy" r
      dums = List.stripPrefix "dummy" r
      tstl = List.stripPrefix "PDBTest" r
      tsts = List.stripPrefix "test" r

data NodeInfo = NodeInfo
  { _nodeInfoName :: !NodeName,
    _nodeInfoDeactivated :: !Bool,
    _nodeInfoCatalogT :: !(S.Maybe UTCTime),
    _nodeInfoFactsT :: !(S.Maybe UTCTime),
    _nodeInfoReportT :: !(S.Maybe UTCTime)
  }

makeClassy ''NodeInfo

instance ToJSON NodeInfo where
  toJSON p =
    object
      [ ("name", toJSON (p ^. nodeInfoName)),
        ("deactivated", toJSON (p ^. nodeInfoDeactivated)),
        ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT)),
        ("facts_timestamp", toJSON (p ^. nodeInfoFactsT)),
        ("report_timestamp", toJSON (p ^. nodeInfoReportT))
      ]

instance FromJSON NodeInfo where
  parseJSON (Object v) =
    NodeInfo
      <$> v .: "name"
      <*> v .:? "deactivated" .!= False
      <*> v .: "catalog_timestamp"
      <*> v .: "facts_timestamp"
      <*> v .: "report_timestamp"
  parseJSON _ = fail "invalide node info"

-- | Pretty straightforward way to define the various PuppetDB queries
data Query a
  = QEqual a Text
  | QG a Integer
  | QL a Integer
  | QGE a Integer
  | QLE a Integer
  | QMatch Text Text
  | QAnd [Query a]
  | QOr [Query a]
  | QNot (Query a)
  | QEmpty

instance (ToJSON a) => ToJSON (Query a) where
  toJSON (QOr qs) = toJSON ("or" : map toJSON qs)
  toJSON (QAnd qs) = toJSON ("and" : map toJSON qs)
  toJSON (QNot q) = toJSON ["not", toJSON q]
  toJSON (QEqual flds val) = toJSON ["=", toJSON flds, toJSON val]
  toJSON (QMatch flds val) = toJSON ["~", toJSON flds, toJSON val]
  toJSON (QL flds val) = toJSON ["<", toJSON flds, toJSON val]
  toJSON (QG flds val) = toJSON [">", toJSON flds, toJSON val]
  toJSON (QLE flds val) = toJSON ["<=", toJSON flds, toJSON val]
  toJSON (QGE flds val) = toJSON [">=", toJSON flds, toJSON val]
  toJSON QEmpty = Null

instance (ToJSON a) => ToHttpApiData (Query a) where
  toHeader = Control.Lens.view strict . encode
  toUrlPiece = decodeUtf8 . toHeader

instance (FromJSON a) => FromJSON (Query a) where
  parseJSON Null = pure QEmpty
  parseJSON (Array elems) = case toList elems of
    ("or" : xs) -> QOr <$> mapM parseJSON xs
    ("and" : xs) -> QAnd <$> mapM parseJSON xs
    ["not", x] -> QNot <$> parseJSON x
    ["=", flds, val] -> QEqual <$> parseJSON flds <*> parseJSON val
    ["~", flds, val] -> QEqual <$> parseJSON flds <*> parseJSON val
    [">", flds, val] -> QG <$> parseJSON flds <*> parseJSON val
    ["<", flds, val] -> QL <$> parseJSON flds <*> parseJSON val
    [">=", flds, val] -> QGE <$> parseJSON flds <*> parseJSON val
    ["<=", flds, val] -> QLE <$> parseJSON flds <*> parseJSON val
    x -> fail ("unknown query" ++ show x)
  parseJSON _ = fail "Expected an array"

-- | Fields for the fact endpoint
data FactField
  = FName
  | FValue
  | FCertname

instance ToJSON FactField where
  toJSON FName = "name"
  toJSON FValue = "value"
  toJSON FCertname = "certname"

instance FromJSON FactField where
  parseJSON "name" = pure FName
  parseJSON "value" = pure FValue
  parseJSON "certname" = pure FCertname
  parseJSON _ = fail "Can't parse fact field"

-- | Fields for the node endpoint
data NodeField = NName | NFact Text

instance ToJSON NodeField where
  toJSON NName = "name"
  toJSON (NFact t) = toJSON ["fact", t]

instance FromJSON NodeField where
  parseJSON (Array xs) = case toList xs of
    ["fact", x] -> NFact <$> parseJSON x
    _ -> fail "Invalid field syntax"
  parseJSON (String "name") = pure NName
  parseJSON _ = fail "invalid field"

-- | Fields for the resource endpoint
data ResourceField
  = RTag
  | RCertname
  | RParameter Text
  | RType
  | RTitle
  | RExported
  | RFile
  | RLine

instance ToJSON ResourceField where
  toJSON RTag = "tag"
  toJSON RCertname = "certname"
  toJSON (RParameter t) = toJSON ["parameter", t]
  toJSON RType = "type"
  toJSON RTitle = "title"
  toJSON RExported = "exported"
  toJSON RFile = "file"
  toJSON RLine = "line"

instance FromJSON ResourceField where
  parseJSON (Array xs) =
    case toList xs of
      ["parameter", x] -> RParameter <$> parseJSON x
      _ -> fail "Invalid field syntax"
  parseJSON (String "tag") = pure RTag
  parseJSON (String "certname") = pure RCertname
  parseJSON (String "type") = pure RType
  parseJSON (String "title") = pure RTitle
  parseJSON (String "exported") = pure RExported
  parseJSON (String "file") = pure RFile
  parseJSON (String "line") = pure RLine
  parseJSON _ = fail "invalid field"

data PuppetDBAPI m = PuppetDBAPI
  { pdbInformation :: m Doc,
    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>
    replaceCatalog :: WireCatalog -> ExceptT PrettyError m (),
    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>
    replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m (),
    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>
    deactivateNode :: NodeName -> ExceptT PrettyError m (),
    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>
    getPDBFacts :: Query FactField -> ExceptT PrettyError m [FactInfo],
    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>
    getResources :: Query ResourceField -> ExceptT PrettyError m [Resource],
    getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo],
    -- | This is only here to tell the test PuppetDB to save its content to disk.
    commitDB :: ExceptT PrettyError m (),
    getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]
  }