dns-patterns 0.2.2 → 0.2.3

raw patch · 8 files changed

+239/−50 lines, 8 filesdep +criteriondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• benchmark/Bench.hs +51/−0
• dns-patterns.cabal +11/−2
• lib/Network/DNS.hs +18/−24
• lib/Network/DNS/Internal.hs +115/−16
• lib/Network/DNS/Internal/Prim.hs +35/−0
• lib/Network/DNS/Pattern.hs +3/−7
• lib/Network/DNS/Pattern/Internal.hs +0/−1

@@ -1,5 +1,11 @@ # Revision history for dns-patterns +## 0.2.3+* Add GHC 9.2 support+* Added the following functions:+  * 'mkDomain\''+* Correctly exposed 'Domain' type and data constructors+ ## 0.2.2 -- 2022-09-08  * Support older bytestring versions

@@ -0,0 +1,51 @@+{-# 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.2+version:            0.2.3 author:             Victor Nawothnig maintainer:         Victor Nawothnig (dminuoso@icloud.com) copyright:          (c) 2022 Wobcom GmbH@@ -17,7 +17,7 @@   common all-    build-depends:    base ^>= { 4.12.0.0, 4.13.0.0, 4.14.1.0, 4.15.0.0 }+    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 }                     , attoparsec ^>= { 0.13.2.5, 0.14.4 }                     , text ^>= { 1.2.4 }                     , bytestring ^>= { 0.10.0, 0.11.0 }@@ -26,6 +26,7 @@     import:           all     exposed-modules:  Network.DNS                     , Network.DNS.Internal+                    , Network.DNS.Internal.Prim                     , Network.DNS.Pattern                     , Network.DNS.Pattern.Internal     build-depends:    parser-combinators ^>= { 1.3.0 }@@ -42,6 +43,14 @@     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

@@ -1,4 +1,3 @@-{-# LANGUAGE MagicHash #-} -- | -- Module      : Network.DNS -- Description : Generic DNS utilities@@ -26,6 +25,7 @@   ( Domain   , getDomain   , mkDomain+  , mkDomain'   , DomainLabel   , getDomainLabel   , getDomainLabelCF@@ -45,6 +45,7 @@   , domainLabelP    -- * Pretty printing+  , pprDomain_   , pprDomain   , pprDomainCF   , pprDomainLabel@@ -54,9 +55,7 @@  import           Data.Char (isDigit, isLower, isUpper) import           Data.Coerce (coerce)-import           GHC.Exts (Addr#, indexWord8OffAddr#)-import           GHC.Int (Int(..))-import           GHC.Word (Word8(..))+import           Data.Word (Word8)  import           Control.Applicative.Combinators import           Control.Monad (when)@@ -69,6 +68,7 @@ import           Data.ByteString.Internal (c2w) import qualified Data.ByteString.Short as BS import qualified Data.Text as T+import qualified Data.Text.Encoding as T  import           Network.DNS.Internal @@ -99,6 +99,12 @@ mkDomain :: [DomainLabel] -> Domain mkDomain = coerce +-- | Turn a list of text labels into a 'Domain'+--+-- Codepoints outside ASCII are officially not supported.+mkDomain' :: [T.Text] -> Domain+mkDomain' xs = mkDomain (mkDomainLabel . BS.toShort . T.encodeUtf8 <$> xs)+ -- | Get the wire-representation of a domain label. {-# INLINE getDomainLabel #-} getDomainLabel :: DomainLabel -> BS.ShortByteString@@ -133,27 +139,12 @@ foldCaseLabel :: DomainLabel -> DomainLabel foldCaseLabel (DomainLabel _l cf) = DomainLabel cf cf +{-# INLINE foldCase_ #-} foldCase_ :: Word8 -> Word8-foldCase_ w = case fromIntegral w of-    I# n -> W8# (indexWord8OffAddr# table n)-  where-    table :: Addr#-    table = "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\-            \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\-            \\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\-            \\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\-            \\x40\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\-            \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x5b\x5c\x5d\x5e\x5f\-            \\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\-            \\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\-            \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\-            \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\-            \\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\-            \\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\-            \\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\-            \\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\-            \\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\-            \\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"#+foldCase_ w | c2w 'A' <= w && w <= c2w 'Z'+            = w + 0x20+            | otherwise+            = w  -- | Print an arbitrary domain into a presentation format. --@@ -165,6 +156,9 @@   where     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). --

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns  #-} {-# LANGUAGE CPP           #-} {-# LANGUAGE MagicHash     #-}+{-# LANGUAGE RankNTypes    #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module      : Network.DNS.Pattern.Internal@@ -17,29 +18,47 @@   , singleton   , sbsMap   , sbsSingleton+  , isLitChar+  , pprLabelsUtf16   )  where +import           Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Short as SBS+import           Data.Foldable (foldl') import           Data.Function (on)+import qualified Data.Text as T import           GHC.Word-#if !MIN_VERSION_bytestring(0,11,3)-import           Control.Monad.ST (runST) import           Data.ByteString.Short.Internal (ShortByteString(SBS))-import           GHC.Exts (Int#, MutableByteArray#, indexWord8Array#,-                           newByteArray#, unsafeFreezeByteArray#,-                           writeWord8Array#, (+#))-import           GHC.Int (Int(..))-import           GHC.ST (ST(..))+import qualified Data.Text.Array as T+import qualified Data.Text.Internal as T+import           GHC.ST (ST(..), runST)+#if !MIN_VERSION_bytestring(0,11,3)+import           GHC.Exts (Int(..), Int#, MutableByteArray#, indexWord8Array#,+                           isTrue#, newByteArray#, unsafeFreezeByteArray#,+                           writeWord8Array#, (+#), (<#))+#else+import           GHC.Exts (Int(..), Int#, MutableByteArray#, indexWord8Array#,+                           isTrue#, newByteArray#, unsafeFreezeByteArray#,+                           writeWord8Array#, (+#), (<#)) #endif -import qualified Data.ByteString.Short as BS+import           Network.DNS.Internal.Prim +isLitChar :: Word8 -> Bool+isLitChar c = (c >= c2w 'a' && c <= c2w 'z')+           || (c >= c2w '0' && c <= c2w '9')+           || (c >= c2w 'A' && c <= c2w 'Z')+           || (c == c2w '_')+           || (c == c2w '-')++ -- | Domain label with case-insensitive 'Eq' and 'Ord' as per [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3).-data DomainLabel = DomainLabel { getDomainLabel_ :: !BS.ShortByteString-                               , getDomainLabelCF_ :: !BS.ShortByteString }+data DomainLabel = DomainLabel { getDomainLabel_ :: !SBS.ShortByteString+                               , getDomainLabelCF_ :: !SBS.ShortByteString } --- | A domain parsed into labels. Each label is a 'BS.ShortByteString' rather than 'T.Text' or 'String' because a label can contain arbitrary bytes.+-- | A domain parsed into labels. Each label is a 'SBS.ShortByteString' rather than 'T.Text' or 'String' because a label can contain arbitrary bytes. -- However, the 'Ord' and 'Eq' instances do limited case-folding according to [RFC4343](https://datatracker.ietf.org/doc/html/rfc4343#section-3). newtype Domain = Domain [DomainLabel] deriving (Eq, Ord) @@ -77,9 +96,9 @@   mempty = DList id  {-# INLINE sbsSingleton #-}-sbsSingleton :: Word8 -> BS.ShortByteString+sbsSingleton :: Word8 -> SBS.ShortByteString #if MIN_VERSION_bytestring(0,11,3)-sbsSingleton = BS.singleton+sbsSingleton = SBS.singleton #else sbsSingleton (W8# w) = runST $ ST $ \s1 ->   case newByteArray# 1# s1 of@@ -89,9 +108,9 @@  #endif -sbsMap :: (Word8 -> Word8) -> BS.ShortByteString -> BS.ShortByteString+sbsMap :: (Word8 -> Word8) -> SBS.ShortByteString -> SBS.ShortByteString #if MIN_VERSION_bytestring(0,11,3)-sbsMap = BS.map+sbsMap = SBS.map #else sbsMap m sbs@(SBS ba) = runST $ ST $ \s1 ->   case newByteArray# l# s1 of@@ -100,7 +119,7 @@         (# s3, _ #) -> case unsafeFreezeByteArray# mba s3 of            (# s4, ma #) -> (# s4, SBS ma #)   where-    !(I# l#) = BS.length sbs+    !(I# l#) = SBS.length sbs     go :: MutableByteArray# s -> Int# -> Int# -> ST s ()     go !mba !i !l       | I# i >= I# l = return ()@@ -109,3 +128,83 @@           (# writeWord8Array# mba i w' s, () #)        ) >> 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+  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++    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 '.']++createSBS :: Int -> (forall s. MBA s -> ST s a) -> SBS.ShortByteString+createSBS len fill = runST $ do+  mba <- newByteArray len+  fill mba+  BA# ba# <- unsafeFreezeByteArray mba+  pure (SBS ba#)++pprLabelUtf16 :: SBS.ShortByteString -> SBS.ShortByteString+pprLabelUtf16 bs = createSBS (pprLabelCodepoints bs * 2) (labelWriterUtf16 bs 0#)++pprLabelCodepoints :: SBS.ShortByteString -> Int+pprLabelCodepoints 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#)+                         | a == c2w '\\'  -> go (i# +# 2#)+                         | a == c2w '.'   -> go (i# +# 2#)+                         | otherwise      -> go (i# +# 3#)+    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.+labelWriterUtf16 :: SBS.ShortByteString -> Int# -> MBA s -> ST s Int+labelWriterUtf16 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 +# 2#)++                         | a == c2w '\\'+                         -> do writeWord8Array0 mba (off)       (c2w '\\')+                               writeWord8Array0 mba (off +# 2#) (c2w '\\')+                               go (i# +# 1#) (off +# 4#)++                         | a == c2w '.'+                         -> do writeWord8Array0 mba (off)       (c2w '\\')+                               writeWord8Array0 mba (off +# 2#) (c2w '.')+                               go (i# +# 1#) (off +# 4#)++                         | otherwise+                         -> do writeWord8Array0 mba (off)       (c2w '\\')+                               writeWord8Array0 mba (off +# 2#) (c2w '0' + o1)+                               writeWord8Array0 mba (off +# 4#) (c2w '0' + o2)+                               writeWord8Array0 mba (off +# 6#) (c2w '0' + o3)+                               go (i# +# 1#) (off +# 8#)+                           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)

@@ -0,0 +1,35 @@+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedTuples #-}+module Network.DNS.Internal.Prim+  ( BA(..)+  , MBA(..)+  , unsafeFreezeByteArray+  , newByteArray+  , writeWord8Array+  , writeWord8Array0+  )+where++import GHC.Exts (ByteArray#, Int#, MutableByteArray#, newByteArray#,+                 unsafeFreezeByteArray#, writeWord8Array#, (+#))+import GHC.Int (Int(..))+import GHC.ST (ST(..))+import GHC.Word (Word8(..))++data BA = BA# ByteArray#+data MBA s = MBA# (MutableByteArray# s)++unsafeFreezeByteArray :: MBA s -> ST s (BA)+unsafeFreezeByteArray (MBA# mab) = ST $ \s1 -> case unsafeFreezeByteArray# mab s1 of+  (# s2, ba #) -> (# s2, BA# ba #)++newByteArray :: Int -> ST s (MBA s)+newByteArray (I# l) = ST $ \s1 -> case newByteArray# l s1 of+  (# s2, mba #) -> (# s2, MBA# mba #)++writeWord8Array :: MBA s -> Int# -> Word8 -> ST s ()+writeWord8Array (MBA# mab) i (W8# w) = ST $ \s -> (# writeWord8Array# mab i w s, () #)++-- | Variant that appends every byte with a 0. This is for embedding ASCII into UTF16 code units.+writeWord8Array0 :: MBA s -> Int# -> Word8 -> ST s ()+writeWord8Array0 mba off w = writeWord8Array mba off w >> writeWord8Array mba (off +# 1#) 0

@@ -39,7 +39,7 @@   ) where -import           Data.Char (isDigit, isLower, isUpper, ord)+import           Data.Char (ord) import           Data.Foldable (asum) import           GHC.Word (Word8) @@ -156,10 +156,6 @@ parsePattern :: T.Text -> Either String DomainPattern parsePattern = A.parseOnly (patternP <* A.endOfInput) --- | Predicate selecting characters allowed in a literal domain pattern.-{-# INLINABLE isLitChar #-}-isLitChar :: Char -> Bool-isLitChar x = isLower x || isDigit x || isUpper x || x == '-' || x == '_'  -- | Variant of 'domainLabelP' that does not admit unescaped asterisk. litPatternP :: A.Parser DomainLabel@@ -167,7 +163,7 @@   where     labelChar :: A.Parser Word8     labelChar = do-        c <- A.satisfy (\x -> isLitChar x || x == '\\') <?> "domain label character"+        c <- A.satisfy (\x -> isLitChar (c2w x) || x == '\\') <?> "domain label character"         case c of             '\\' -> escape             _    -> pure (c2w c)@@ -202,7 +198,7 @@     {-# INLINE replace #-}     replace :: [Word8] -> [Char]     replace (x:xs) = case x of-      _ | isLitChar (w2c x) -> (w2c x) : replace xs+      _ | isLitChar x -> w2c x : replace xs        0x2a -> '\\' : '*' : replace xs       0x2e -> '\\' : '.' : replace xs

@@ -13,7 +13,6 @@ where  import Network.DNS.Internal- -- | A domain pattern. newtype DomainPattern = DomainPattern   { getDomainPattern :: [LabelPattern]