dns-patterns 0.2.3 → 0.3.1

raw patch · 6 files changed

+149/−87 lines, 6 filesdep −criteriondep ~basedep ~bytestringdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies removed: criterion

Dependency ranges changed: base, bytestring, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• benchmark/Bench.hs +0/−51
• dns-patterns.cabal +4/−12
• lib/Network/DNS.hs +5/−6
• lib/Network/DNS/Internal.hs +97/−18
• test/Spec.hs +34/−0

@@ -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:

@@ -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-      }

@@ -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

@@ -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

@@ -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 

@@ -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