{-# 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 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 (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."))
]