Common.hs

{-# LANGUAGE LambdaCase #-}
-- | Common data types for PuppetDB.
module PuppetDB.Common where

import           Puppet.Prelude           hiding (Read)

import           Data.List                (stripPrefix)
import           Data.Maybe
import           Data.Vector.Lens
import           GHC.Read                 (Read (..))
import           Network.HTTP.Client
import           Servant.Common.BaseUrl
import           System.Environment

import           Puppet.Interpreter.Types
import           PuppetDB.Dummy
import           PuppetDB.Remote
import           PuppetDB.TestDB

-- | The supported PuppetDB implementations.
data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.
             | PDBDummy -- ^ A stupid stub, this is the default choice.
             | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file.
             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 = stripPrefix "PDBRemote" r
            rems = stripPrefix "remote"    r
            duml = stripPrefix "PDBDummy"  r
            dums = stripPrefix "dummy"     r
            tstl = stripPrefix "PDBTest"   r
            tsts = stripPrefix "test"      r

-- | 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
  url <- parseBaseUrl "http://localhost:8080"
  mgr <- newManager defaultManagerSettings
  pdbConnect mgr url
getDefaultDB PDBTest   = lookupEnv "HOME" >>= \case
                                Just h -> loadTestDB (h ++ "/.testdb")
                                Nothing -> fmap Right initTestDB

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