{-# LANGUAGE OverloadedStrings #-}
module Main

where

import           Data.Coerce (coerce)
import           Data.String

import qualified Data.ByteString as BS
import qualified Data.Text as T
import           Test.HUnit.Base
import           Test.HUnit.Text

import           Network.DNS.Pattern

instance IsString DomainPattern where
  fromString s = case parsePattern (T.pack s) of
    Right s  -> s
    Left err -> error ("DomPat: no parse, " <> err)

instance IsString DomainLabel where
  fromString s = case parseDomainLabel (T.pack s) of
    Right s  -> s
    Left err -> error ("DomainLabel: no parse, " <> err)

instance IsString Domain where
  fromString s = case parseAbsDomain (T.pack s) of
    Right s  -> s
    Left err -> error ("Domain: no parse, " <> err)

instance Show Domain where
  showsPrec _ d = mappend (T.unpack (pprDomain d))

instance Show DomainPattern where
  showsPrec _ d = mappend (T.unpack (pprPattern d))

instance Show DomainLabel where
  showsPrec _ d = mappend (T.unpack (pprDomainLabel d))

main :: IO ()
main = do
  runTestTTAndExit $ TestList
    [ patternMatchSpecs
    , patternParseSpecs
    , equalitySpecs
    , caseFoldSpecs
    , patternContainedSpecs
    , pprRoundTrips
    ]


equalitySpecs :: Test
equalitySpecs = TestList
    [ TestCase $ assertEqual "case-fold ASCII characters for comparison"
                 (Right True)
                 (do l <- parseAbsDomain "foo."
                     r <- parseAbsDomain "Foo."
                     pure (l == r)
                 )

    , TestCase $ assertEqual "do not case-fold ASCII characters in the latin-supplement"
                 (Right False)
                 (do l <- parseAbsDomain "\\335."
                     r <- parseAbsDomain "\\375."
                     pure (l == r)
                 )
    ]

parseDomainSpecs :: Test
parseDomainSpecs = TestList
    [ TestCase $ assertBool "do not parse relative domains"
                 (isLeft (parseAbsDomain "foo"))

    , TestCase $ assertBool "do not parse deeper relative domains"
                 (isLeft (parseAbsDomain "foo.bar"))

    , TestCase $ assertEqual "parse simple absolute domains"
                 (Right (Domain ["foo"]))
                 (parseAbsDomain "foo.")

    , TestCase $ assertEqual "parse deeper absolute domains"
                 (Right (Domain ["foo", "bar"]))
                 (parseAbsDomain "foo.bar.")

    , TestCase $ assertEqual "parse domains with arbitrary bytes"
                 (Right (Domain ["\\000", "\\777"]))
                 (parseAbsDomain "\\000.\\777.")

    , TestCase $ assertBool "parse domains with 63 octets labels"
                 (isRight (parseAbsDomain (T.pack (replicate 63 '1' <> "."))))

    , TestCase $ assertBool "do not parse domains with labels longer than 63 octets"
                 (isLeft (parseAbsDomain (T.pack (replicate 64 '1' <> "."))))

    , TestCase $ assertEqual "parses relative domains in relaxed mode"
                 (Right (Domain ["foo", "bar"]))
                 (parseAbsDomainRelax "foo.bar")

    , TestCase $ assertEqual "parses absolute domains in relaxed mode"
                 (Right (Domain ["foo", "bar"]))
                 (parseAbsDomainRelax "foo.bar.")
    ]

patternParseSpecs :: Test
patternParseSpecs = TestList
    [ TestCase $ assertBool "do not allow globstar in the middle"
                 (isLeft  (parsePattern "foo.**.bar."))

    , TestCase $ assertBool "do not allow globstar in the right"
                 (isLeft (parsePattern "foo.**."))

    , TestCase $ assertEqual "allow complex patterns with everything"
                 (Right (DomainPattern [ DomGlobStar
                                       , DomLiteral "quux"
                                       , DomGlob
                                       , DomLiteral "foo"
                                       , DomLiteral "bar"]))
                 (parsePattern "**.quux.*.foo.bar.")

    , TestCase $ assertEqual "allow simple literal pattern"
                 (Right (DomainPattern [DomLiteral "foo"]))
                 (parsePattern "foo.")

    , TestCase $ assertBool "do not allow relative domain patterns"
                 (isLeft (parsePattern "foo"))

    , TestCase $ assertBool "do not allow empty domain patterns"
                 (isLeft (parsePattern ""))

    , TestCase $ assertEqual "allow a top-level globstar pattern"
                 (Right (DomainPattern [DomGlobStar]))
                 (parsePattern "**.")

    , TestCase $ assertEqual "allow a top-level glob pattern"
                 (Right (DomainPattern [DomGlob]))
                 (parsePattern "*.")

    , TestCase $ assertEqual "allow a simple root pattern"
                 (Right (DomainPattern []))
                 (parsePattern ".")

    , TestCase $ assertEqual "allow escapable characters in patterns"
                 (parsePattern "\\..\\*.\\\\.")
                 (Right (DomainPattern [ DomLiteral "."
                                       , DomLiteral "*"
                                       , DomLiteral "\\" ]))

    , TestCase $ assertBool "Does not allow unescaped asterisk"
                 (isLeft (parsePattern "a*."))

    , TestCase $ assertBool "Does not allow unesacped escape character with non-escapable character"
                 (isLeft (parsePattern "a\\a."))

    , TestCase $ assertBool "does not allow octets other than non-ascii codepoints in patterns"
                 (isLeft (parsePattern "\000.\777."))
    ]

isRight :: Either a b -> Bool
isRight Right{} = True
isRight _       = True

isLeft :: Either a b -> Bool
isLeft Left{} = True
isLeft _      = False


pprRoundTrips :: Test
pprRoundTrips = TestList
  [ TestCase $ assertEqual "patterns roundtrip between parse and ppr"
               (Right True)
               (do let input = "**.*.\\.\\*\\000.foo."
                   r <- parsePattern input
                   pure (pprPattern r == input))

  , TestCase $ assertEqual "domains roundtrip between parse and ppr"
               (Right True)
               (do let input = "**.*\\000.foo."
                   r <- parseAbsDomain input
                   pure (pprDomain r == input))

  ]

caseFoldSpecs :: Test
caseFoldSpecs = TestList
  [ let d = "Foo.Bar." in
    TestCase $ assertEqual "t1" d (foldCase d)

  , let d = "foo.bar." in
    TestCase $ assertEqual "t2" d (foldCase d)

  , let d = "FOO.BAR." in
    TestCase $ assertEqual "t3" d (foldCase d)

  , let l = "Foo" in
    TestCase $ assertEqual "t4" l (foldCaseLabel l)
  ]


patternMatchSpecs :: Test
patternMatchSpecs = TestList
  [     ("."                   `matchesPattern` ".")           ~? "Matches literal of the root"
  ,     ("foo.bar."            `matchesPattern` "foo.bar.")    ~? "Matches literal"
  , not ("bar."                `matchesPattern` "foo.bar.")    ~? "Does not match literal"

  ,     ("foo.sub.bar."        `matchesPattern` "foo.*.bar.")  ~? "Matches glob"
  , not ("foo.sub.quux."       `matchesPattern` "foo.*.bar.")  ~? "Does not match glob"
  , not ("sub.quux."           `matchesPattern` "*.bar.")      ~? "Does not match glob"


  ,     ("sub.foo.bar."        `matchesPattern` "*.foo.bar.")  ~? "Matches glob"
  , not ("sub.foo.quux."       `matchesPattern` "*.foo.bar.")  ~? "Does not match glob"
  , not ("sub2.sub1.foo.quux." `matchesPattern` "*.foo.bar.")  ~? "Does not match glob"

  ,     ("sub1.foo.bar."       `matchesPattern` "**.foo.bar.") ~? "Matches globstar"
  ,     ("sub2.sub2.foo.bar."  `matchesPattern` "**.foo.bar.") ~? "Matches globstar"
  , not ("sub1.foo.quux."      `matchesPattern` "**.foo.bar.") ~? "Does not match globstar"

  ]

patternContainedSpecs :: Test
patternContainedSpecs = TestList
  [ TestCase $ assertBool "t1" ("foo.*.bar."    `patternWorksInside` "quux.bar.")
  , TestCase $ assertBool "t2" ("foo.bar."      `patternWorksInside` "bar.")
  , TestCase $ assertBool "t3" ("bar."          `patternWorksInside` "bar.")
  , TestCase $ assertBool "t4" (not ("foo.bar." `patternWorksInside` "quux."))
  ]