content: module HieraSpec (spec) where
  
  import qualified Data.HashMap.Strict as HM
  import qualified Data.Vector as Vector
  import Hiera.Server
  import Puppet.Language
  import qualified System.Log.Logger as Log
  import Test.Hspec
  import XPrelude
  
  checkOutput :: (Eq a, Show rr, Show a) => a -> Either rr a -> Expectation
  checkOutput v (Right x) = x `shouldBe` v
  checkOutput _ (Left rr) = expectationFailure (show rr)
  
  checkFail :: (Show a) => Either rr a -> Expectation
  checkFail (Right v) = expectationFailure ("Should have failed, but returned: " ++ show v)
  checkFail _ = return ()
  
  fqdn :: Text
  fqdn = "node.com"
  
  config_v3 :: FilePath
  config_v3 = "./tests/hiera/hiera-v3.yaml"
  
  config_v5 :: FilePath
  config_v5 = "./tests/hiera/hiera-v5.yaml"
  
  configMisc :: FilePath
  configMisc = "./tests/hiera/misc/config/hiera.yaml"
  
  configInterpolate :: FilePath
  configInterpolate = "./tests/hiera/interpolate/config/hiera.yaml"
  
  vars :: HM.HashMap Text PValue
  vars =
    HM.fromList
      [ ("::environment", "production"),
        ("::fqdn", PString fqdn)
      ]
  
  users :: HM.HashMap Text PValue
  users =
    HM.fromList
      [ ("pete", PHash (HM.singleton "uid" (PNumber 2000))),
        ("tom", PHash (HM.singleton "uid" (PNumber 2001)))
      ]
  
  pusers :: HM.HashMap Text PValue
  pusers =
    HM.fromList
      [ ("bob", PHash (HM.singleton "uid" (PNumber 100))),
        ("tom", PHash (HM.singleton "uid" (PNumber 12)))
      ]
  
  hash :: [(Text, PValue)] -> PValue
  hash = PHash . HM.fromList
  
  array :: [PValue] -> PValue
  array = PArray . Vector.fromList
  
  spec :: Spec
  spec = do
    runIO $ Log.updateGlobalLogger loggerName (Log.setLevel Log.WARNING)
    q3_ <- runIO $ startHiera "test" config_v3
    q5_ <- runIO $ startHiera "test" config_v5
    let q5 vrs var t = runExceptT (q5_ vrs var t)
        q3 vrs var t = runExceptT (q3_ vrs var t)
    describe "Hiera" $ do
      interpolationSpec
      miscSpec
      describe "v5 lookup hierarchy" $
        it "should override some values" $ do
          q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))
          q5 vars "global" QFirst >>= checkOutput (Just "glob")
      describe "v5 ~" $
        it "should read '~' as a Null/Nothing value" $
          q5 vars "optional_value" QFirst >>= checkOutput (Just PUndef)
      describe "v3 lookup with no context variables" $ do
        it "should return nothing when called with an empty string" $
          q3 mempty "" QFirst >>= checkOutput Nothing
        it "should return nothing when called with a non existent key [First merge]" $
          q3 mempty "foo" QFirst >>= checkOutput Nothing
        it "should return nothing when called with a non existent key [Unique merge]" $
          q3 mempty "foo" QUnique >>= checkOutput Nothing
        it "should return nothing when called with a non existent key [Hash merge]" $
          q3 mempty "foo" QHash >>= checkOutput Nothing
        it "should return common data" $
          q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080))
        it "should return arrays" $
          q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (array ["0.ntp.puppetlabs.com", "1.ntp.puppetlabs.com"]))
        it "should return hashes" $
          q3 mempty "users" QFirst >>= checkOutput (Just (PHash users))
      describe "v3 lookup hierarchy" $ do
        it "should override value" $
          q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))
        it "should find common value" $
          q3 vars "global" QFirst >>= checkOutput (Just "glob")
      describe "v3 json backend" $
        it "resolves in json" $
          q3 vars "testjson" QFirst >>= checkOutput (Just "ok")
      describe "v3 deep interpolation" $ do
        it "resolves in strings" $
          q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> fqdn <> "**")))
        it "resolves in objects" $
          q3 vars "testnode" QFirst >>= checkOutput (Just (hash [("1", PString ("**" <> fqdn <> "**")), ("2", PString "nothing special")]))
        it "resolves in arrays" $
          q3 vars "arraytest" QFirst >>= checkOutput (Just (array [PString "a", PString fqdn, PString "c"]))
        it "resolves aliases" $
          q3 vars "aliased" QFirst >>= checkOutput (Just (array [PString "a", PString "b"]))
        it "resolves integers to strings" $
          q3 vars "server" QFirst >>= checkOutput (Just (PString "127.0.0.1:9090"))
        it "resolves lookus" $
          q3 vars "aliased_lookup" QFirst >>= checkOutput (Just (PNumber 100))
      describe "v3 other merge modes" $ do
        it "catenates arrays" $
          q3 vars "ntp_servers" QUnique >>= checkOutput (Just (array ["2.ntp.puppetlabs.com", "3.ntp.puppetlabs.com", "0.ntp.puppetlabs.com", "1.ntp.puppetlabs.com"]))
        it "puts single values in arrays" $
          q3 vars "http_port" QUnique >>= checkOutput (Just (array [PNumber 9090, PNumber 8080]))
        it "merges hashes" $
          q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))
  
  miscSpec :: Spec
  miscSpec = describe "misc" $ do
    q_ <- runIO $ startHiera "test" configMisc
    let q vrs var t = runExceptT (q_ vrs var t)
    it "should return bar on the basic test" $
      q mempty "foo" QFirst >>= checkOutput (Just "bar")
    it "should work with the literal function" $
      q mempty "literal" QFirst >>= checkOutput (Just "%{SERVER_NAME}")
  
  interpolationSpec :: Spec
  interpolationSpec =
    describe "interpolation" $ do
      q_ <- runIO $ startHiera "test" configInterpolate
      let q vrs var t = runExceptT (q_ vrs var t)
      describe "when doing interpolation" $ do
        it "should prevent endless recursion" $
          q mempty "foo" QFirst >>= checkFail
        it "produces a nested hash with arrays from nested aliases with hashes and arrays" $
          q mempty "root" QHash >>= checkOutput (Just (hash [("a", hash [("aa", hash [("b", hash [("bb", PArray (Vector.fromList ["text"]))])])])]))
        it "allows keys with white space" $
          q mempty "ws_key" QFirst >>= checkOutput (Just "value for a ws key")
        it "allows keys with non alphanumeric characters" $
          q mempty "angry" QFirst >>= checkOutput (Just "not happy")
  
      describe "when not finding value for interpolated key" $
        it "should resolve the interpolation to an empty string" $
          q mempty "niltest" QFirst >>= checkFail -- puppet behavior: checkOutput (Just "Missing key ##. Key with nil ##")
      describe "when there are empty interpolations %{} in data" $ do
        it "should should produce an empty string for the interpolation" $ do
          pendingWith "Support empty interpolation"
          q mempty "empty_interpolation" QFirst >>= checkOutput (Just "clownshoe")
        it "the empty interpolation can be escaped" $ do
          pendingWith "Support empty interpolation"
          q mempty "escaped_empty_interpolation" QFirst >>= checkOutput (Just "clown%{shoe}s")
        it "the value can consist of only an empty escape" $ do
          pendingWith "Support empty interpolation"
          q mempty "only_empty_interpolation" QFirst >>= checkOutput (Just "")
        it "the value can consist of an empty namespace %{::}" $ do
          pendingWith "Support empty interpolation"
          q mempty "empty_namespace" QFirst >>= checkOutput (Just "")
        it "the value can consist of whitespace %{ :: }" $ do
          pendingWith "Support empty interpolation"
          q mempty "whitespace1" QFirst >>= checkOutput (Just "")
        it "the value can consist of whitespace %{  }" $ do
          pendingWith "Support empty interpolation"
          q mempty "whitespace2" QFirst >>= checkOutput (Just "")
  
      describe "when there are quoted empty interpolations %{} in data" $ do
        it "should should produce an empty string for the interpolation" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_empty_interpolation" QFirst >>= checkOutput (Just "clownshoe")
        it "the empty interpolation can be escaped" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_escaped_empty_interpolation" QFirst >>= checkOutput (Just "clown%{shoe}s")
        it "the value can consist of only an empty escape" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_only_empty_interpolation" QFirst >>= checkOutput (Just "")
        it "the value can consist of an empty namespace %{::}" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_empty_namespace" QFirst >>= checkOutput (Just "")
        it "the value can consist of whitespace %{ :: }" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_whitespace1" QFirst >>= checkOutput (Just "")
        it "the value can consist of whitespace %{  }" $ do
          pendingWith "Support empty interpolation"
          q mempty "quoted_whitespace2" QFirst >>= checkOutput (Just "")
  
      describe "varsplitter" $ do
        it "no splitting" $ varSplitter "abcd" `shouldBe` HieraVar ("abcd" :| [])
        it "split 2" $ varSplitter "ab.cd" `shouldBe` HieraVar ("ab" :| ["cd"])
        it "split 3" $ varSplitter "ab.cd.ef" `shouldBe` HieraVar ("ab" :| ["cd", "ef"])
        it "split dq" $ varSplitter "\"ab\"" `shouldBe` HieraVar ("ab" :| [])
        it "split dq 2" $ varSplitter "\"ab.cd\"" `shouldBe` HieraVar ("ab.cd" :| [])
        it "split dq 2 mixed" $ varSplitter "\"ab.cd\".ef" `shouldBe` HieraVar ("ab.cd" :| ["ef"])
        it "split dq 2 mixed 4" $
          varSplitter "\"ab.cd\".ef.\"lol.cat\".bar"
            `shouldBe` HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])
        it "split sq" $ varSplitter "'ab'" `shouldBe` HieraVar ("ab" :| [])
        it "split sq 2" $ varSplitter "'ab.cd'" `shouldBe` HieraVar ("ab.cd" :| [])
        it "split sq 2 mixed" $ varSplitter "'ab.cd'.ef" `shouldBe` HieraVar ("ab.cd" :| ["ef"])
        it "split sq 2 mixed 4" $
          varSplitter "'ab.cd'.ef.'lol.cat'.bar"
            `shouldBe` HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])
        it "split all mixed" $
          varSplitter "'a.b'.\"c.d\".e.f"
            `shouldBe` HieraVar ("a.b" :| ["c.d", "e", "f"])
        it "function f()" $
          varSplitter "f()"
            `shouldBe` HieraFunction ("f" :| []) []
        it "function f('a')" $
          varSplitter "f('a')"
            `shouldBe` HieraFunction ("f" :| []) ["a"]
        it "function f('a', 'b', 'c')" $
          varSplitter "f('a', 'b', 'c')"
            `shouldBe` HieraFunction ("f" :| []) ["a", "b", "c"]
  
      describe "when using dotted keys" $ do
        it "should find an entry using a quoted interpolation" $
          q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.scope\"" QFirst >>= checkOutput (Just "a dot c: (scope) a dot b")
        it "should find an entry using a quoted interpolation with method hiera" $
          q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.hiera\"" QFirst >>= checkOutput (Just "a dot c: (hiera) a dot b")
        it "should find an entry using a quoted interpolation with method alias" $
          q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.alias\"" QFirst >>= checkOutput (Just "(hiera) a dot b")
        it "should use a dotted key to navigate into a structure when it is not quoted" $
          q (HM.fromList [("a", hash [("d", "(scope) a dot d is a hash entry")])]) "\"a.e.scope\"" QFirst >>= checkOutput (Just "a dot e: (scope) a dot d is a hash entry")
        it "should use a dotted key to navigate into a structure when when it is not quoted with method hiera" $
          q (HM.fromList [("a", hash [("d", "(scope) a dot d is a hash entry")])]) "\"a.e.hiera\"" QFirst >>= checkOutput (Just "a dot e: (hiera) a dot d is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is last" $
          q (HM.fromList [("a", hash [("d.x", "(scope) a dot d.x is a hash entry")])]) "\"a.ex.scope\"" QFirst >>= checkOutput (Just "a dot ex: (scope) a dot d.x is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is last and method is hiera" $
          q (HM.fromList [("a", hash [("d.x", "(scope) a dot d.x is a hash entry")])]) "\"a.ex.hiera\"" QFirst >>= checkOutput (Just "a dot ex: (hiera) a dot d.x is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is first" $
          q (HM.fromList [("a.x", hash [("d", "(scope) a.x dot d is a hash entry")])]) "\"a.xe.scope\"" QFirst >>= checkOutput (Just "a dot xe: (scope) a.x dot d is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is first and method is hiera" $
          q (HM.fromList [("a.x", hash [("d", "(scope) a.x dot d is a hash entry")])]) "\"a.xe.hiera\"" QFirst >>= checkOutput (Just "a dot xe: (hiera) a.x dot d is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle" $
          q (HM.fromList [("a", hash [("d.z", hash [("g", "(scope) a dot d.z dot g is a hash entry")])])]) "\"a.xm.scope\"" QFirst >>= checkOutput (Just "a dot xm: (scope) a dot d.z dot g is a hash entry")
        it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle and method is hiera" $
          q (HM.fromList [("a", hash [("d.z", hash [("g", "(scope) a dot d.z dot g is a hash entry")])])]) "\"a.xm.hiera\"" QFirst >>= checkOutput (Just "a dot xm: (hiera) a dot d.z dot g is a hash entry")
        it "should use a mix of several quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle" $
          q (HM.fromList [("a.x", hash [("d.z", hash [("g", "(scope) a.x dot d.z dot g is a hash entry")])])]) "\"a.xx.scope\"" QFirst >>= checkOutput (Just "a dot xx: (scope) a.x dot d.z dot g is a hash entry")
        it "should use a mix of several quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle and method is hiera" $
          q (HM.fromList [("a.x", hash [("d.z", hash [("g", "(scope) a.x dot d.z dot g is a hash entry")])])]) "\"a.xx.hiera\"" QFirst >>= checkOutput (Just "a dot xx: (hiera) a.x dot d.z dot g is a hash entry")
        it "should find an entry using using a quoted interpolation on dotted key containing numbers" $
          q (HM.fromList [("x.1", "(scope) x dot 1")]) "\"x.2.scope\"" QFirst >>= checkOutput (Just "x dot 2: (scope) x dot 1")
        it "should find an entry using using a quoted interpolation on dotted key containing numbers using method hiera" $
          q (HM.fromList [("x.1", "(scope) x dot 1")]) "\"x.2.hiera\"" QFirst >>= checkOutput (Just "x dot 2: (hiera) x dot 1")
        it "will allow strange characters in the key" $
          q mempty "very_angry" QFirst >>= checkOutput (Just "not happy at all")
        it "should not find a subkey when the dotted key is quoted" $
          q (HM.fromList [("a", hash [("f", "(scope) a dot f is a hash entry")])]) "\"a.f.scope\"" QFirst >>= checkFail -- real hiera : checkOutput (Just "a dot f: ")
        it "should not find a subkey when the dotted key is quoted with method hiera" $
          q (HM.fromList [("a", hash [("f", "(scope) a dot f is a hash entry")])]) "\"a.f.hiera\"" QFirst >>= checkFail -- real hiera : checkOutput (Just "a dot f: ")
        it "should not find a subkey that is matched within a string" $
          q mempty "ipl_key" QFirst >>= checkFail
        it "should not find a subkey that is matched within a string" $
          q mempty "key.subkey" QFirst >>= checkFail
  