language-puppet-1.1.5: tests/InterpreterSpec.hs

module InterpreterSpec (collectorSpec, main) where

import           Control.Lens
import           Data.HashMap.Strict      (HashMap)
import qualified Data.HashMap.Strict      as HM
import           Data.Monoid
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Vector              as V
import           Test.Hspec
import           Text.Megaparsec          (eof, parse)

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

appendArrowNode :: Text
appendArrowNode = "appendArrow"

arrowOperationInput :: ArrowOp -> Text
arrowOperationInput arr = T.unlines [ "node " <> appendArrowNode <> " {"
                  , "user { 'jenkins':"
                  , "  groups => 'ci'"
                  , "}"
                  , "User <| title == 'jenkins' |> {"
                  , "groups " <> (prettyToText . pretty) arr <> " 'docker',"
                  , "uid => 1000}"
                  , "}"
                  ]

getResAttr ::
  (Either
     PrettyError
     (FinalCatalog, EdgeMap, FinalCatalog, [Resource]),
      InterpreterState,
      InterpreterWriter)
  -> Container PValue
getResAttr s =
  let finalcatalog = s ^._1._Right._1
  in finalcatalog ^. at (RIdentifier "user" "jenkins")._Just.rattributes


collectorSpec :: Spec
collectorSpec = do
  let computeWith arr = pureCompute appendArrowNode (arrowOperationInput arr)
  describe "Resource Collector" $
    it "should append the new 'uid' attribute in the user resource" $
      getResAttr (computeWith AssignArrow) ^. at "uid" `shouldBe` Just (PNumber 1000)
  describe "AppendArrow in AttributeDecl" $
    it "should add 'docker' to the 'groups' attribute of the user resource" $
      getResAttr (computeWith AppendArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["ci", "docker"])
  describe "AssignArrow in AttributeDecl" $
    it "should override the 'groups' attributes from the user resource" $
      getResAttr (computeWith AssignArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"])

main :: IO ()
main = hspec collectorSpec

-- | Given a node and raw text input to be parsed, compute the manifest in a dummy setting.
pureCompute :: NodeName
            -> Text
            -> (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]),
                InterpreterState,
                InterpreterWriter)
pureCompute node input =
  let hush :: Show a => Either a b -> b
      hush = either (error . show) id

      getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement
      getStatement n i = HM.singleton (TopNode, n) (nodeStatement i)

      nodeStatement :: Text -> Statement
      nodeStatement i = V.head $ hush $ parse (puppetParser <* eof) "test" i

  in pureEval dummyFacts (getStatement node input) (computeCatalog node)