language-puppet-1.5.1: src/PuppetDB.hs

-- | Common data types for PuppetDB.
module PuppetDB
  ( dummyPuppetDB,
    getDefaultDB,
    pdbConnect,
    loadTestDB,
    generateWireCatalog,
    puppetDBFacts,
    module PuppetDB.Core,
  )
where

import Control.Arrow ((***))
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as Text
import Data.Vector.Lens
import Facter
import Network.HTTP.Client
import Puppet.Language
import PuppetDB.Core
import PuppetDB.Remote
import PuppetDB.TestDB
import System.Environment
import XPrelude

-- | Given a 'PDBType', will try return a sane default implementation.
getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO))
getDefaultDB PDBDummy = return (Right dummyPuppetDB)
getDefaultDB PDBRemote = do
  let url = "http://localhost:8080"
  mgr <- newManager defaultManagerSettings
  pdbConnect mgr url
getDefaultDB PDBTest =
  lookupEnv "HOME" >>= \case
    Just h -> loadTestDB (h <> "/.testdb")
    Nothing -> fmap Right initTestDB

-- | A dummy implementation of 'PuppetDBAPI', that will return empty responses.
dummyPuppetDB :: (Monad m) => PuppetDBAPI m
dummyPuppetDB =
  PuppetDBAPI
    (return "dummy")
    (const (return ()))
    (const (return ()))
    (const (return ()))
    (const (throwError "not implemented"))
    (const (return []))
    (const (return []))
    (throwError "not implemented")
    (\_ _ -> return [])

-- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be
-- serialized and fed to @puppet apply@.
generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog
generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid"
  where
    edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)
    resources = toVectorOf folded cat

puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (HashMap Text PValue)
puppetDBFacts node pdbapi =
  runExceptT (getPDBFacts pdbapi (QEqual FCertname node)) >>= \case
    Right facts@(_ : _) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))
    _ -> do
      rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])
      let ofacts = genFacts $ map (Text.pack *** Text.pack) rawFacts
          (hostname, ddomainname) = Text.break (== '.') node
          domainname =
            if Text.null ddomainname
              then ""
              else Text.tail ddomainname
          nfacts =
            genFacts
              [ ("fqdn", node),
                ("hostname", hostname),
                ("domain", domainname),
                ("rootrsa", "xxx"),
                ("operatingsystem", "Ubuntu"),
                ("puppetversion", "language-puppet"),
                ("virtual", "xenu"),
                ("clientcert", node),
                ("is_virtual", "true"),
                ("concat_basedir", "/var/lib/puppet/concat")
              ]
          allfacts = nfacts `Map.union` ofacts
          genFacts = Map.fromList
      return (allfacts & traverse %~ PString & buildOSHash)

buildOSHash :: Facts -> Facts
buildOSHash facts = case buildObject topLevel of
  Nothing -> facts
  Just os -> facts & at "os" ?~ os
  where
    buildObject keys =
      let nobject = foldl' addKey mempty keys
       in if nobject == mempty
            then Nothing
            else Just (PHash nobject)
    g k = facts ^? ix k
    topLevel =
      [ ("name", g "operatingsystem"),
        ("family", g "osfamily"),
        ("release", buildObject [("major", g "lsbdistrelease"), ("full", g "lsbdistrelease")]),
        ( "lsb",
          buildObject
            [ ("distcodename", g "lsbdistcodename"),
              ("distid", g "lsbdistid"),
              ("distdescription", g "lsbdistdescription"),
              ("distrelease", g "lsbdistrelease"),
              ("majdistrelease", g "lsbmajdistrelease")
            ]
        )
      ]
    addKey hash (k, mv) = case mv of
      Nothing -> hash
      Just v -> hash & at k ?~ v