diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/benchmark/Bench.hs b/benchmark/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Bench.hs @@ -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 + } 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.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 diff --git a/lib/Network/DNS.hs b/lib/Network/DNS.hs --- a/lib/Network/DNS.hs +++ b/lib/Network/DNS.hs @@ -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). -- 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 @@ -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) diff --git a/lib/Network/DNS/Internal/Prim.hs b/lib/Network/DNS/Internal/Prim.hs new file mode 100644 --- /dev/null +++ b/lib/Network/DNS/Internal/Prim.hs @@ -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 diff --git a/lib/Network/DNS/Pattern.hs b/lib/Network/DNS/Pattern.hs --- a/lib/Network/DNS/Pattern.hs +++ b/lib/Network/DNS/Pattern.hs @@ -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 diff --git a/lib/Network/DNS/Pattern/Internal.hs b/lib/Network/DNS/Pattern/Internal.hs --- a/lib/Network/DNS/Pattern/Internal.hs +++ b/lib/Network/DNS/Pattern/Internal.hs @@ -13,7 +13,6 @@ where import Network.DNS.Internal - -- | A domain pattern. newtype DomainPattern = DomainPattern { getDomainPattern :: [LabelPattern]