diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for dns-patterns +## 0.3.1 +* Correctly reject domains with labels longer than 63 octets + +## 0.3.0 +* Add GHC 9.4 support +* Add text-2.0 support +* Removed pprDomain_ from public API +* Fix memory bug in pprLabelUtf16 + ## 0.2.3 * Add GHC 9.2 support * Added the following functions: diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs deleted file mode 100644 --- a/benchmark/Bench.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Criterion -import Criterion.Main -import Criterion.Types - - -import Network.DNS -import Network.DNS.Pattern -import Network.DNS.Pattern.Internal - -unsafeRight :: Either l r -> r -unsafeRight e = case e of - Right r -> r - Left l -> error "unsafeRight: left!" - -{-# NOINLINE d1 #-} -d1 :: Domain -d1 = unsafeRight (parseAbsDomain "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.4.1.0.0.1.0.0.0.1.8.5.0.1.0.a.2.ip6.arpa.") - -{-# NOINLINE d2 #-} -d2 :: Domain -d2 = unsafeRight (parseAbsDomain "0.1.1.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.a.e.c.5.a.b.c.1.2.b.b.d.f.ip6.arpa.") - -{-# NOINLINE d3 #-} -d3 :: Domain -d3 = unsafeRight (parseAbsDomain "0.1.124.10.in-addr.arpa.") - -{-# NOINLINE d4 #-} -d4 :: Domain -d4 = unsafeRight (parseAbsDomain "ihvs0317.as9136.net.") - - -main = defaultMainWith cfg - [ bgroup "pprDomain_" [ bench "text prim: d1" $ whnf pprDomain_ d1 - , bench "text prim: d2" $ whnf pprDomain_ d2 - , bench "text prim: d3" $ whnf pprDomain_ d3 - , bench "text prim: d4" $ whnf pprDomain_ d4 ] - - , bgroup "pprDomain" [ bench "dlist+builder: d1" $ whnf pprDomain d1 - , bench "dlist+builder: d2" $ whnf pprDomain d2 - , bench "dlist+builder: d3" $ whnf pprDomain d3 - , bench "dlist+builder: d4" $ whnf pprDomain d4 ] - ] - - where - cfg = defaultConfig - { reportFile = Just "/home/dminuoso/criterion.report" - , rawDataFile = Just "/home/dminuoso/criterion.raw" - , verbosity = Verbose - } diff --git a/dns-patterns.cabal b/dns-patterns.cabal --- a/dns-patterns.cabal +++ b/dns-patterns.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: dns-patterns -version: 0.2.3 +version: 0.3.1 author: Victor Nawothnig maintainer: Victor Nawothnig (dminuoso@icloud.com) copyright: (c) 2022 Wobcom GmbH @@ -17,10 +17,10 @@ common all - build-depends: base ^>= { 4.12.0.0, 4.13.0.0, 4.14.1.0, 4.15.0.0, 4.16.2.0, 4.16.1.0, 4.16.3.0 } + build-depends: base >= 4.12.0.0 && < 4.20.0.0 , attoparsec ^>= { 0.13.2.5, 0.14.4 } - , text ^>= { 1.2.4 } - , bytestring ^>= { 0.10.0, 0.11.0 } + , text >= 2.0.0 && < 2.2 + , bytestring >= 0.10 && < 0.13 library import: all @@ -43,14 +43,6 @@ hs-source-dirs: test default-language: Haskell2010 -benchmark bench - import: all - type: exitcode-stdio-1.0 - main-is: Bench.hs - build-depends: criterion - , dns-patterns - hs-source-dirs: benchmark - default-language: Haskell2010 source-repository head type: git location: git@gitlab.com:wobcom/haskell/dns-patterns.git diff --git a/lib/Network/DNS.hs b/lib/Network/DNS.hs --- a/lib/Network/DNS.hs +++ b/lib/Network/DNS.hs @@ -45,7 +45,6 @@ , domainLabelP -- * Pretty printing - , pprDomain_ , pprDomain , pprDomainCF , pprDomainLabel @@ -123,7 +122,6 @@ unsafeMkDomainLabel :: BS.ShortByteString -> DomainLabel unsafeMkDomainLabel l = DomainLabel l l - -- | Unsafely construct a 'DomainLabel' from a single Word8. The argument must already be case-folded according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). unsafeSingletonDomainLabel :: Word8 -> DomainLabel unsafeSingletonDomainLabel l = DomainLabel (sbsSingleton l) (sbsSingleton l) @@ -157,9 +155,6 @@ build :: DList Char build = foldr (\x buf -> buildLabel x <> singleton '.' <> buf) mempty l -pprDomain_ :: Domain -> T.Text -pprDomain_ (Domain ls) = pprLabelsUtf16 (getDomainLabel_ <$> ls) - -- | Print an arbitrary domain into a presentation format after case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). -- -- This function nearly roundtrips with 'parseAbsDomain' up to escape sequence equivalence and case folding. @@ -222,7 +217,11 @@ -- | Attoparsec 'A.Parser' for a singular domain label. See 'parseDomainLabel' for a convenince wrapper. Also see 'absDomainP'. domainLabelP :: A.Parser DomainLabel -domainLabelP = mkDomainLabel . BS.pack <$> (some labelChar) +domainLabelP = do + label <- some labelChar + when (length label >= 64) $ + fail "domain label too long" + pure (mkDomainLabel (BS.pack label)) where labelChar :: A.Parser Word8 labelChar = do diff --git a/lib/Network/DNS/Internal.hs b/lib/Network/DNS/Internal.hs --- a/lib/Network/DNS/Internal.hs +++ b/lib/Network/DNS/Internal.hs @@ -19,7 +19,11 @@ , sbsMap , sbsSingleton , isLitChar + , pprLabelUtf16 + , pprLabelUtf8 , pprLabelsUtf16 + , pprLabelsUtf8 + , pprLabels ) where @@ -38,10 +42,9 @@ import GHC.Exts (Int(..), Int#, MutableByteArray#, indexWord8Array#, isTrue#, newByteArray#, unsafeFreezeByteArray#, writeWord8Array#, (+#), (<#)) + #else -import GHC.Exts (Int(..), Int#, MutableByteArray#, indexWord8Array#, - isTrue#, newByteArray#, unsafeFreezeByteArray#, - writeWord8Array#, (+#), (<#)) +import GHC.Exts (Int(..), Int#, indexWord8Array#, isTrue#, (+#), (<#)) #endif import Network.DNS.Internal.Prim @@ -129,52 +132,128 @@ ) >> go mba (i +# 1#) l #endif -pprLabelsUtf16 :: [SBS.ShortByteString] -> T.Text -pprLabelsUtf16 xs@(_:_) = let SBS ba = createSBS (codePoints * 2) (go xs 0#) - in T.text (T.Array ba) 0 codePoints +pprLabels :: [SBS.ShortByteString] -> T.Text +#if MIN_VERSION_text(2,0,0) +pprLabels xs = let !(# codePoints, SBS ba #) = pprLabelsUtf8' xs + in T.text (T.ByteArray ba) 0 codePoints +#else +pprLabels xs = let !(# codePoints, SBS ba #) = pprLabelsUtf16' xs + in T.text (T.Array ba) 0 codePoints +#endif + + +pprLabelsUtf8 :: [SBS.ShortByteString] -> SBS.ShortByteString +pprLabelsUtf8 xs = case pprLabelsUtf8' xs of + (# _, out #) -> out + +pprLabelsUtf8' :: [SBS.ShortByteString] -> (# Int, SBS.ShortByteString #) +pprLabelsUtf8' xs@(_:_) = (# codePoints, createSBS codePoints (go xs 0#) #) where -- We adjust for an extra codepoint to account per label for the dot separators. -- The case of root zone domain names (empty list, pretty-prints to ".") is handled + -- in a separate `domainEncoderUtf8` definition below. + codePoints = foldl' (\a x -> a + labelUnicodeCodepoints x + 1) 0 xs + + go (a:as) off mba = do I# off' <- labelWriterUtf8 a off mba + writeWord8Array0 mba off' (c2w '.') + go as (off' +# 1#) mba + + go [] _off _mba = pure () +pprLabelsUtf8' [] = (# 1, SBS.pack [c2w '.'] #) + +pprLabelsUtf16 :: [SBS.ShortByteString] -> SBS.ShortByteString +pprLabelsUtf16 xs = case pprLabelsUtf16' xs of + (# _, out #) -> out + +pprLabelsUtf16' :: [SBS.ShortByteString] -> (# Int, SBS.ShortByteString #) +pprLabelsUtf16' xs@(_:_) = (# codePoints, createSBS (codePoints * 2) (go xs 0#) #) + where + -- We adjust for an extra codepoint to account per label for the dot separators. + -- The case of root zone domain names (empty list, pretty-prints to ".") is handled -- in a separate `domainEncoderUtf16` definition below. - codePoints = foldl' (\a x -> a + pprLabelCodepoints x + 1) 0 xs + codePoints = foldl' (\a x -> a + labelUnicodeCodepoints x + 1) 0 xs go (a:as) off mba = do I# off' <- labelWriterUtf16 a off mba writeWord8Array0 mba off' (c2w '.') go as (off' +# 2#) mba - go [] off _mba = pure () -pprLabelsUtf16 [] = T.pack "." - -domainEncoderUtf16 :: [a] -> ShortByteString -domainEncoderUtf16 [] = SBS.pack [c2w '.'] + go [] _off _mba = pure () +pprLabelsUtf16' [] = (# 1, SBS.pack [c2w '.'] #) createSBS :: Int -> (forall s. MBA s -> ST s a) -> SBS.ShortByteString createSBS len fill = runST $ do mba <- newByteArray len - fill mba + _ <- fill mba BA# ba# <- unsafeFreezeByteArray mba pure (SBS ba#) +pprLabelUtf8 :: SBS.ShortByteString -> SBS.ShortByteString +pprLabelUtf8 bs = createSBS (labelUnicodeCodepoints bs) (labelWriterUtf8 bs 0#) + pprLabelUtf16 :: SBS.ShortByteString -> SBS.ShortByteString -pprLabelUtf16 bs = createSBS (pprLabelCodepoints bs * 2) (labelWriterUtf16 bs 0#) +pprLabelUtf16 bs = createSBS (labelUnicodeCodepoints bs * 2) (labelWriterUtf16 bs 0#) -pprLabelCodepoints :: SBS.ShortByteString -> Int -pprLabelCodepoints sbs@(SBS ba) = go 0# +labelUnicodeCodepoints :: SBS.ShortByteString -> Int +labelUnicodeCodepoints sbs@(SBS ba) = go 0# where !(I# len) = SBS.length sbs go i# | isTrue# (i# <# len) = let a = W8# (indexWord8Array# ba i#) in case () of _ | isLitChar a -> go (i# +# 1#) + -- We escape backslashes with a backslash | a == c2w '\\' -> go (i# +# 2#) + + -- We escape dots with a backslash | a == c2w '.' -> go (i# +# 2#) - | otherwise -> go (i# +# 3#) + + -- Everything else gets octal encoded (three octals) and a backslash + | otherwise -> go (i# +# 4#) go i = I# i -- Create an ST action to write to a mutable byte array, starting at some offset. Returns -- the new offset where we can resume writing to. +labelWriterUtf8 :: SBS.ShortByteString -> Int# -> MBA s -> ST s Int +labelWriterUtf8 sbs@(SBS ba) off' mba = go 0# off' + where + !(I# len) = SBS.length sbs + + go i# off | isTrue# (i# <# len) + = let a = W8# (indexWord8Array# ba i#) + in case () of + _ | isLitChar a + -> do writeWord8Array0 mba (off) a + go (i# +# 1#) (off +# 1#) + + | a == c2w '\\' + -> do writeWord8Array0 mba (off) (c2w '\\') + writeWord8Array0 mba (off +# 1#) (c2w '\\') + go (i# +# 1#) (off +# 2#) + + | a == c2w '.' + -> do writeWord8Array0 mba (off) (c2w '\\') + writeWord8Array0 mba (off +# 1#) (c2w '.') + go (i# +# 1#) (off +# 2#) + + | otherwise + -> do writeWord8Array0 mba (off) (c2w '\\') + writeWord8Array0 mba (off +# 1#) (c2w '0' + o1) + writeWord8Array0 mba (off +# 2#) (c2w '0' + o2) + writeWord8Array0 mba (off +# 3#) (c2w '0' + o3) + go (i# +# 1#) (off +# 4#) + where + (# o1, o2, o3 #) = case quotRem a 8 of + (v1, r3) -> case quotRem v1 8 of + (v2, r2) -> case quotRem v2 8 of + (_, r1) -> (# r1, r2, r3 #) + | otherwise + = pure (I# off) + + +-- Create an ST action to write to a mutable byte array, starting at some offset. Returns +-- the new offset where we can resume writing to. labelWriterUtf16 :: SBS.ShortByteString -> Int# -> MBA s -> ST s Int -labelWriterUtf16 sbs@(SBS ba) off mba = go 0# off +labelWriterUtf16 sbs@(SBS ba) off' mba = go 0# off' where !(I# len) = SBS.length sbs diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,6 +7,7 @@ import Data.Coerce (coerce) import Data.String +import qualified Data.ByteString.Short as SBS import qualified Data.ByteString as BS import qualified Data.Text as T import Test.HUnit.Base @@ -14,6 +15,7 @@ import GHC.IO.Handle (NewlineMode(inputNL)) import Network.DNS +import Network.DNS.Internal import Network.DNS.Pattern import Network.DNS.Pattern.Internal @@ -57,6 +59,8 @@ , patternContainedSpecs , pprRoundTrips , pprSpecs + , pprInternal + , parseDomainSpecs ] @@ -216,6 +220,36 @@ "-_" (pprDomainLabelCF lab) ] + +pprInternal :: Test +pprInternal = TestList + [ let input :: [SBS.ShortByteString] + input = ["dot.", "com"] + in TestCase $ assertEqual "pi1: correctly escapes dots" + "dot\\..com." + (pprLabels input) + , let input :: [SBS.ShortByteString] + input = ["backslash\\", "com"] + in TestCase $ assertEqual "pi2: correctly escapes backslashes" + "backslash\\\\.com." + (pprLabels input) + , let input :: [SBS.ShortByteString] + input = ["newline\n", "com"] + in TestCase $ assertEqual "pi3: correctly escapes arbitrary ascii codepoints" + "newline\\012.com." + (pprLabels input) + , let input :: [SBS.ShortByteString] + input = ["com"] + in TestCase $ assertEqual "pi4: correctly encodes UTF16BE" + "\x63\x00\x6F\x00\x6D\x00\x2E\x00" + (pprLabelsUtf16 input) + , let input :: [SBS.ShortByteString] + input = ["com"] + in TestCase $ assertEqual "pi5: correctly encodes UTF8" + "\x63\x6F\x6D\x2E" + (pprLabelsUtf8 input) + ] + pprRoundTrips :: Test pprRoundTrips = TestList [ let input = "**.*.\\.\\000.foo." in