{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
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           GHC.IO.Handle (NewlineMode(inputNL))
import           Network.DNS
import           Network.DNS.Pattern
import           Network.DNS.Pattern.Internal

instance IsString DomainPattern where
  fromString = unsafeParseDomainPattern . T.pack

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

instance IsString Domain where
  fromString = unsafeParseDomain . T.pack

instance Show Domain where
  show = T.unpack . pprDomain

deriving instance Show DomainPattern
instance Show DomainLabel where
  show = T.unpack . pprDomainLabel

deriving instance Show LabelPattern

unsafeParseDomainPattern :: T.Text -> DomainPattern
unsafeParseDomainPattern s = case parsePattern s of
    Right s  -> s
    Left err -> error ("DomPat: failed to parse: " <> T.unpack s)

unsafeParseDomain :: T.Text -> Domain
unsafeParseDomain s = case parseAbsDomain s of
    Right s  -> s
    Left err -> error ("Domain: failed to parse: " <> T.unpack s)

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


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 a label containing an asterisk "
                 (Right (Domain ["foo*bar"]))
                 (parseAbsDomain "foo*bar.")

    , TestCase $ assertEqual "parse a label containing just asterisk "
                 (Right (Domain ["*"]))
                 (parseAbsDomain "*.")

    , 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 "parse escaped asterisk into an asterisk literal"
                 (Right (DomainPattern [DomLiteral "*"]))
                 (parsePattern "\\*.")

    , TestCase $ assertEqual "parse escaped asterisk in infix position into a literal"
                 (Right (DomainPattern [DomLiteral "foo*bar"]))
                 (parsePattern "foo\\*bar.")

    , 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 (mkDomainLabel ".")
                                       , DomLiteral (mkDomainLabel "\\") ]))

    , 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


pprSpecs :: Test
pprSpecs = TestList
  [ let lab = mkDomainLabel "." in
        TestCase $ assertEqual "p1: correctly escapes dots"
             "\\."
             (pprDomainLabel lab)
  , let lab = mkDomainLabel "." in
        TestCase $ assertEqual "p2: correctly escapes dots after case folding"
             "\\."
             (pprDomainLabelCF lab)

  , let lab = mkDomainLabel "\\" in
        TestCase $ assertEqual "p3: correctly escapes backslash"
             "\\\\"
             (pprDomainLabel lab)

  , let lab = mkDomainLabel "\\" in
        TestCase $ assertEqual "p4: correctly escapes backslash after case folding"
             "\\\\"
             (pprDomainLabelCF lab)

  , let lab = mkDomainLabel "-_" in
        TestCase $ assertEqual "p5: correctly does not escape hyphen or underscore"
             "-_"
             (pprDomainLabelCF lab)
  ]
pprRoundTrips :: Test
pprRoundTrips = TestList
  [ let input = "**.*.\\.\\000.foo." in
        TestCase $ assertEqual "p1: patterns roundtrip between parse and ppr"
               input
               (pprPattern (unsafeParseDomainPattern input))

  , let input = "\\000.foo." in
          TestCase $ assertEqual "p2: domains roundtrip between parse and ppr"
               input
               (pprDomain (unsafeParseDomain 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."))
  ]