content: -- | 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
  