{-# 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))
main :: IO ()
main = do
runTestTTAndExit $ TestList
[ patternMatchSpecs
, patternParseSpecs
, equalitySpecs
, 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")
]
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))
]
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."))
]