diff --git a/Data/IP.hs b/Data/IP.hs --- a/Data/IP.hs +++ b/Data/IP.hs @@ -5,9 +5,15 @@ -- * IP data IP (..) -- ** IPv4 - , IPv4, toIPv4, fromIPv4, fromHostAddress, toHostAddress + , IPv4 + , toIPv4, toIPv4w + , fromIPv4, fromIPv4w + , fromHostAddress, toHostAddress -- ** IPv6 - , IPv6, toIPv6, toIPv6b, fromIPv6, fromIPv6b, fromHostAddress6, toHostAddress6 + , IPv6 + , toIPv6, toIPv6b, toIPv6w + , fromIPv6, fromIPv6b, fromIPv6w + , fromHostAddress6, toHostAddress6 -- ** Converters , ipv4ToIPv6 , fromSockAddr diff --git a/Data/IP/Addr.hs b/Data/IP/Addr.hs --- a/Data/IP/Addr.hs +++ b/Data/IP/Addr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -258,85 +259,186 @@ -- {-| - The 'toIPv4' function takes a list of 'Int' and returns 'IPv4'. + The 'toIPv4' function returns the 'IPv4' address corresponding to the given + list of 'Int' octets. The function is strict in the four elements of the + list. An error is returned if the list has a differnet length. The input + elements are silently truncated to their 8 least-significant bits before they + are combined to form the IPv4 address. >>> toIPv4 [192,0,2,1] 192.0.2.1 -} toIPv4 :: [Int] -> IPv4 -toIPv4 = IP4 . toWord32 +toIPv4 [a1, a2, a3, a4] = IP4 w where - toWord32 [a1,a2,a3,a4] = fromIntegral $ shift a1 24 + shift a2 16 + shift a3 8 + a4 - toWord32 _ = error "toWord32" + w = (fromIntegral a1 .&. 0xff) `unsafeShiftL` 24 .|. + (fromIntegral a2 .&. 0xff) `unsafeShiftL` 16 .|. + (fromIntegral a3 .&. 0xff) `unsafeShiftL` 8 .|. + (fromIntegral a4 .&. 0xff) +toIPv4 _ = error "IPv4 field list length != 4" +{-# INLINE toIPv4 #-} {-| - The 'toIPv6' function takes a list of 'Int' and returns 'IPv6'. + The 'toIPv4w' function constructs the 'IPv4' address corresponding to the + given 'Word32' value. Unlike the 'fromHostAddress' function, it is strict in + the input value, which here is in host byte order. +>>> toIPv4w 0xc0000201 +192.0.2.1 + +@since 1.7.9 +-} +toIPv4w :: Word32 -> IPv4 +toIPv4w w = IP4 w +{-# INLINE toIPv4w #-} + +{-| + The 'toIPv6' function returns the 'IPv6' address corresponding to the given + list of eight 16-bit 'Int's. The function is strict in the eight elements of + the list. An error is returned if the list has a differnet length. The + input elements are in host byte order and are silently truncated to their 16 + least-signicant bits before they are combined to form the IPv6 address. + >>> toIPv6 [0x2001,0xDB8,0,0,0,0,0,1] 2001:db8::1 -} toIPv6 :: [Int] -> IPv6 -toIPv6 ad = IP6 (x1,x2,x3,x4) +toIPv6 [i1,i2,i3,i4,i5,i6,i7,i8] = IP6 (x1,x2,x3,x4) where - [x1,x2,x3,x4] = map toWord32 $ split2 ad - split2 [] = [] - split2 x = take 2 x : split2 (drop 2 x) - toWord32 [a1,a2] = fromIntegral $ shift a1 16 + a2 - toWord32 _ = error "toWord32" + !x1 = fromIntegral $ (i1 .&. 0xffff) `unsafeShiftL` 16 .|. (i2 .&. 0xffff) + !x2 = fromIntegral $ (i3 .&. 0xffff) `unsafeShiftL` 16 .|. (i4 .&. 0xffff) + !x3 = fromIntegral $ (i5 .&. 0xffff) `unsafeShiftL` 16 .|. (i6 .&. 0xffff) + !x4 = fromIntegral $ (i7 .&. 0xffff) `unsafeShiftL` 16 .|. (i8 .&. 0xffff) +toIPv6 _ = error "toIPv6 field list length != 8" +{-# INLINE toIPv6 #-} {-| - The 'toIPv6b' function takes a list of 'Int' - where each member repserents a single byte and returns 'IPv6'. + The 'toIPv6b' function returns the IPv6 address corresponding to the given + list of sixteen 'Int' octets. The function is strict in the sixteen elements + of the list. An error is returned if the list has a differnet length. The + input elements are silently truncated to their 8 least-signicant bits before + they are combined to form the IPv6 address. >>> toIPv6b [0x20,0x01,0xD,0xB8,0,0,0,0,0,0,0,0,0,0,0,1] 2001:db8::1 -} toIPv6b :: [Int] -> IPv6 -toIPv6b ad = IP6 (x1,x2,x3,x4) +toIPv6b [ h11, h12, l11, l12, h21, h22, l21, l22 + , h31, h32, l31, l32, h41, h42, l41, l42 ] = IP6 (x1,x2,x3,x4) where - [x1,x2,x3,x4] = map toWord32 $ split4 ad - split4 [] = [] - split4 x = take 4 x : split4 (drop 4 x) - toWord32 [a1,a2,a3,a4] = fromIntegral $ shift a1 24 + shift a2 16 + shift a3 8 + a4 - toWord32 _ = error "toWord32" + !x1 = fromIntegral $ (h11 .&. 0xff) `unsafeShiftL` 24 .|. + (h12 .&. 0xff) `unsafeShiftL` 16 .|. + (l11 .&. 0xff) `unsafeShiftL` 8 .|. + (l12 .&. 0xff) + !x2 = fromIntegral $ (h21 .&. 0xff) `unsafeShiftL` 24 .|. + (h22 .&. 0xff) `unsafeShiftL` 16 .|. + (l21 .&. 0xff) `unsafeShiftL` 8 .|. + (l22 .&. 0xff) + !x3 = fromIntegral $ (h31 .&. 0xff) `unsafeShiftL` 24 .|. + (h32 .&. 0xff) `unsafeShiftL` 16 .|. + (l31 .&. 0xff) `unsafeShiftL` 8 .|. + (l32 .&. 0xff) + !x4 = fromIntegral $ (h41 .&. 0xff) `unsafeShiftL` 24 .|. + (h42 .&. 0xff) `unsafeShiftL` 16 .|. + (l41 .&. 0xff) `unsafeShiftL` 8 .|. + (l42 .&. 0xff) +toIPv6b _ = error "toIPv6b field list length != 16" +{-| + The 'toIPv6w' function constructs the 'IPv6' address corresponding to the + given four-tuple of host byte order 'Word32' values. This function differs + from the 'fromHostAddress6' function only in the fact that it is strict in + the elements of the tuple. + +>>> toIPv6w (0x20010DB8,0x0,0x0,0x1) +2001:db8::1 + +@since 1.7.9 +-} +toIPv6w :: (Word32, Word32, Word32, Word32) -> IPv6 +toIPv6w w@(!_, !_, !_, !_) = IP6 w +{-# INLINE toIPv6w #-} + ---------------------------------------------------------------- -- -- IPToInt -- {-| - The 'fromIPv4' function converts 'IPv4' to a list of 'Int'. + The 'fromIPv4' function returns the list of four 'Int' octets corresponding + to the given 'IPv4' address. >>> fromIPv4 (toIPv4 [192,0,2,1]) [192,0,2,1] -} fromIPv4 :: IPv4 -> [Int] -fromIPv4 (IP4 w) = map (\n -> fromEnum $ (w `shiftR` n) .&. 0xff) [0o30, 0o20, 0o10, 0o00] +fromIPv4 (IP4 w) = split w 0o30 : split w 0o20 : split w 0o10 : split w 0 : [] + where + split :: Word32 -> Int -> Int + split a n = fromIntegral $ a `unsafeShiftR` n .&. 0xff +{-# INLINE fromIPv4 #-} {-| - The 'toIPv6' function converts 'IPv6' to a list of 'Int'. + The 'fromIPv4w' function returns a single 'Word32' value corresponding to the + given the 'IPv4' address. Unlike the 'toHostAddress' function, the returned + value is strictly evaluated, and is not converted to network byte order. +>>> fromIPv4w (toIPv4 [0xc0,0,2,1]) == 0xc0000201 +True + +@since 1.7.9 +-} +fromIPv4w :: IPv4 -> Word32 +fromIPv4w (IP4 !ip4rep) = ip4rep +{-# INLINE fromIPv4w #-} + +{-| + The 'fromIPv6' function returns a list eight 'Int's in host byte order + corresponding to the eight 16-bit fragments of the given IPv6 address. + >>> fromIPv6 (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) [8193,3512,0,0,0,0,0,1] -} fromIPv6 :: IPv6 -> [Int] -fromIPv6 (IP6 (w1, w2, w3, w4)) = map fromEnum (concatMap split [w1,w2,w3,w4]) +fromIPv6 (IP6 (w1, w2, w3, w4)) = + split w1 . split w2 . split w3 . split w4 $ [] where - split :: Word32 -> [Word32] - split n = [n `shiftR` 0x10 .&. 0xffff, n .&. 0xffff] + split :: Word32 -> [Int] -> [Int] + split n acc = fromIntegral (n `unsafeShiftR` 0x10 .&. 0xffff) : + fromIntegral (n .&. 0xffff) : acc +{-# INLINE fromIPv6 #-} {-| - The 'fromIPv6b' function converts 'IPv6' to a list of 'Int' - where each member represents a single byte. + The 'fromIPv6b' function returns the 16 'Int' octets corresponding + to the 16 bytes of the given IPv6 address. >>> fromIPv6b (toIPv6b [0x20,0x01,0xD,0xB8,0,0,0,0,0,0,0,0,0,0,0,1]) [32,1,13,184,0,0,0,0,0,0,0,0,0,0,0,1] -} fromIPv6b :: IPv6 -> [Int] -fromIPv6b (IP6 (w1, w2, w3, w4)) = map fromEnum (concatMap split [w1,w2,w3,w4]) +fromIPv6b (IP6 (w1, w2, w3, w4)) = + split w1 . split w2 . split w3 . split w4 $ [] where - split n = fmap (\s -> n `shiftR` s .&. 0xff) [24,16,8,0] + split :: Word32 -> [Int] -> [Int] + split n acc = fromIntegral (n `unsafeShiftR` 24 .&. 0xff) : + fromIntegral (n `unsafeShiftR` 16 .&. 0xff) : + fromIntegral (n `unsafeShiftR` 8 .&. 0xff) : + fromIntegral (n .&. 0xff) : acc + +{-| + The 'fromIPv6w' function returns a four-tuple of 'Word32' values in host byte + order corresponding to the given 'IPv6' address. This is identical to the + 'toHostAddress6' function, except that the elements of four-tuple are + first strictly evaluated. + +>>> fromIPv6w (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) == (0x20010DB8, 0, 0, 1) +True + +@since 1.7.9 +-} +fromIPv6w :: IPv6 -> (Word32, Word32, Word32, Word32) +fromIPv6w (IP6 ip6rep) = ip6rep +{-# INLINE fromIPv6w #-} ---------------------------------------------------------------- -- diff --git a/Data/IP/Builder.hs b/Data/IP/Builder.hs new file mode 100644 --- /dev/null +++ b/Data/IP/Builder.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TupleSections #-} + +module Data.IP.Builder + ( -- * 'P.BoundedPrim' 'B.Builder's for general, IPv4 and IPv6 addresses. + ipBuilder + , ipv4Builder + , ipv6Builder + ) where + +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as P +import Data.ByteString.Builder.Prim ((>$<), (>*<)) +import GHC.Exts +import GHC.Word (Word8(..), Word16(..), Word32(..)) + +import Data.IP.Addr + +------------ IP builders + +{-# INLINE ipBuilder #-} +-- | 'P.BoundedPrim' bytestring 'B.Builder' for general 'IP' addresses. +ipBuilder :: IP -> B.Builder +ipBuilder (IPv4 addr) = ipv4Builder addr +ipBuilder (IPv6 addr) = ipv6Builder addr + +{-# INLINE ipv4Builder #-} +-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv4' addresses. +ipv4Builder :: IPv4 -> B.Builder +ipv4Builder addr = P.primBounded ipv4Bounded $! fromIPv4w addr + +{-# INLINE ipv6Builder #-} +-- | 'P.BoundedPrim' bytestring 'B.Builder' for 'IPv6' addresses. +ipv6Builder :: IPv6 -> B.Builder +ipv6Builder addr = P.primBounded ipv6Bounded $! fromIPv6w addr + +------------ Builder utilities + +-- Convert fixed to bounded for fusion +toB :: P.FixedPrim a -> P.BoundedPrim a +toB = P.liftFixedToBounded +{-# INLINE toB #-} + +{-# INLINE ipv4Bounded #-} +ipv4Bounded :: P.BoundedPrim Word32 +ipv4Bounded = + quads >$< ((P.word8Dec >*< dotsep) >*< (P.word8Dec >*< dotsep)) + >*< ((P.word8Dec >*< dotsep) >*< P.word8Dec) + where + quads a = ((qdot 0o30# a, qdot 0o20# a), (qdot 0o10# a, qfin a)) + {-# INLINE quads #-} + qdot s (W32# a) = (W8# ((a `uncheckedShiftRL#` s) `and#` 0xff##), ()) + {-# INLINE qdot #-} + qfin (W32# a) = W8# (a `and#` 0xff##) + {-# INLINE qfin #-} + dotsep = const 0x2e >$< toB P.word8 + +-- | For each of the 32-bit chunks of an IPv6 address, encode how it should be +-- displayed in the presentation form of the address, based its location +-- relative to the "best gap", i.e. the left-most longest run of zeros. The +-- "hi" and, or "lo" parts are accompanied by occasional units mapped to colons. +-- +data FF = CHL {-# UNPACK #-} ! Word32 -- ^ :: + | HL {-# UNPACK #-} ! Word32 -- ^ : + | NOP -- ^ nop + | COL -- ^ : + | CLO {-# UNPACK #-} ! Word32 -- ^ : + | CC -- ^ : : + | CHC {-# UNPACK #-} ! Word32 -- ^ :: + | HC {-# UNPACK #-} ! Word32 -- ^ : + +-- Build an IPv6 address in conformance with +-- [RFC5952](http://tools.ietf.org/html/rfc5952 RFC 5952). +-- +{-# INLINE ipv6Bounded #-} +ipv6Bounded :: P.BoundedPrim (Word32, Word32, Word32, Word32) +ipv6Bounded = + P.condB generalCase + ( genFields >$< output128 ) + ( P.condB v4mapped + ( pairPair >$< (colsep >*< colsep) + >*< (ffff >*< (fstUnit >$< colsep >*< ipv4Bounded)) ) + ( pairPair >$< (P.emptyB >*< colsep) >*< (colsep >*< ipv4Bounded) ) ) + where + -- The boundedPrim switches and predicates need to be inlined for best + -- performance, gaining a factor of ~2 in throughput in tests. + -- + {-# INLINE output128 #-} + {-# INLINE output64 #-} + {-# INLINE generalCase #-} + {-# INLINE v4mapped #-} + {-# INLINE output32 #-} + + generalCase :: (Word32, Word32, Word32, Word32) -> Bool + generalCase (w0, w1, w2, w3) = + w0 /= 0 || w1 /= 0 || (w2 /= 0xffff && (w2 /= 0 || w3 <= 0xffff)) + -- + v4mapped :: (Word32, Word32, Word32, Word32) -> Bool + v4mapped (w0, w1, w2, _) = + w0 == 0 && w1 == 0 && w2 == 0xffff + + -- BoundedPrim for the full 128-bit IPv6 address given as + -- a pair of pairs of FF values, which encode the + -- output format of each of the 32-bit chunks. + -- + output128 :: P.BoundedPrim ((FF, FF), (FF, FF)) + output128 = output64 >*< output64 + output64 = (output32 >*< output32) + -- + -- And finally the per-word case-work. + -- + output32 :: P.BoundedPrim FF + output32 = + P.condB ffCond03 + ( P.condB ffCond01 + ( P.condB ffCond0 + build_CHL -- :: + build_HL ) -- : + ( P.condB ffCond2 + build_NOP -- nop + build_COL ) ) -- : + ( P.condB ffCond45 + ( P.condB ffCond4 + build_CLO -- : + build_CC ) -- : : + ( P.condB ffCond6 + build_CHC -- :: + build_HC ) ) -- : + + -- Branch selection predicates + ffCond03 = \case { CHL _ -> True; HL _ -> True; + NOP -> True; COL -> True; _ -> False } + ffCond01 = \case { CHL _ -> True; HL _ -> True; _ -> False } + ffCond45 = \case { CC -> True; CLO _ -> True; _ -> False } + ffCond0 = \case { CHL _ -> True; _ -> False } + ffCond2 = \case { NOP -> True; _ -> False } + ffCond4 = \case { CLO _ -> True; _ -> False } + ffCond6 = \case { CHC _ -> True; _ -> False } + + -- encoders for the seven field format (FF) cases. + -- + build_CHL = (\ (CHL w) -> ( fstUnit (hi16 w), fstUnit (lo16 w) ) ) + >$< (colsep >*< P.word16Hex) + >*< (colsep >*< P.word16Hex) + -- + build_HL = (\ (HL w) -> ( hi16 w, fstUnit (lo16 w) ) ) + >$< P.word16Hex >*< colsep >*< P.word16Hex + -- + build_NOP = P.emptyB + -- + build_COL = const () >$< colsep + -- + build_CC = const ((), ()) >$< colsep >*< colsep + -- + build_CLO = (\ (CLO w) -> fstUnit (lo16 w) ) + >$< colsep >*< P.word16Hex + -- + build_CHC = (\ (CHC w) -> fstUnit (sndUnit (hi16 w)) ) + >$< colsep >*< P.word16Hex >*< colsep + -- + build_HC = (\ (HC w) -> sndUnit (hi16 w)) + >$< P.word16Hex >*< colsep + + -- static encoders + -- + colsep :: P.BoundedPrim a + colsep = toB $ const 0x3a >$< P.word8 + -- + ffff :: P.BoundedPrim a + ffff = toB $ const 0xffff >$< P.word16HexFixed + + -- | Helpers + hi16, lo16 :: Word32 -> Word16 + hi16 !(W32# w) = W16# (w `uncheckedShiftRL#` 16#) + lo16 !(W32# w) = W16# (w `and#` 0xffff##) + -- + fstUnit :: a -> ((), a) + fstUnit = ((), ) + -- + sndUnit :: a -> (a, ()) + sndUnit = (, ()) + -- + pairPair (a, b, c, d) = ((a, b), (c, d)) + + -- Construct fields decorated with output format details + genFields (w0, w1, w2, w3) = + let !(!gapStart, !gapEnd) = bestgap w0 w1 w2 w3 + !f0 = makeF0 gapStart gapEnd w0 + !f1 = makeF12 gapStart gapEnd 2# 3# w1 + !f2 = makeF12 gapStart gapEnd 4# 5# w2 + !f3 = makeF3 gapStart gapEnd w3 + in ((f0, f1), (f2, f3)) + + makeF0 (I# gapStart) (I# gapEnd) !w = + case (gapEnd ==# 0#) `orI#` (gapStart ># 1#) of + 1# -> HL w + _ -> case gapStart ==# 0# of + 1# -> COL + _ -> HC w + {-# INLINE makeF0 #-} + + makeF12 (I# gapStart) (I# gapEnd) il ir !w = + case (gapEnd <=# il) `orI#` (gapStart ># ir) of + 1# -> CHL w + _ -> case gapStart >=# il of + 1# -> case gapStart ==# il of + 1# -> COL + _ -> CHC w + _ -> case gapEnd ==# ir of + 0# -> NOP + _ -> CLO w + {-# INLINE makeF12 #-} + + makeF3 (I# gapStart) (I# gapEnd) !w = + case gapEnd <=# 6# of + 1# -> CHL w + _ -> case gapStart ==# 6# of + 0# -> case gapEnd ==# 8# of + 1# -> COL + _ -> CLO w + _ -> CC + {-# INLINE makeF3 #-} + +-- | Unrolled and inlined calculation of the first longest +-- run (gap) of 16-bit aligned zeros in the input address. +-- +bestgap :: Word32 -> Word32 -> Word32 -> Word32 -> (Int, Int) +bestgap !(W32# a0) !(W32# a1) !(W32# a2) !(W32# a3) = + finalGap + (updateGap (0xffff## `and#` a3) + (updateGap (0xffff0000## `and#` a3) + (updateGap (0xffff## `and#` a2) + (updateGap (0xffff0000## `and#` a2) + (updateGap (0xffff## `and#` a1) + (updateGap (0xffff0000## `and#` a1) + (updateGap (0xffff## `and#` a0) + (initGap (0xffff0000## `and#` a0))))))))) + where + + -- The state after the first input word is always i' = 7, + -- but if the input word is zero, then also g=z=1 and e'=7. + initGap :: Word# -> Int# + initGap w = case w of { 0## -> 0x1717#; _ -> 0x0707# } + + -- Update the nibbles of g|e'|z|i' based on the next input + -- word. We always decrement i', reset z on non-zero input, + -- otherwise increment z and check for a new best gap, if so + -- we replace g|e' with z|i'. + updateGap :: Word# -> Int# -> Int# + updateGap w g = case w `neWord#` 0## of + 1# -> (g +# 0xffff#) `andI#` 0xff0f# -- g, e, 0, --i + _ -> let old = g +# 0xf# -- ++z, --i + zi = old `andI#` 0xff# + new = (zi `uncheckedIShiftL#` 8#) `orI#` zi + in case new ># old of + 1# -> new -- z, i, z, i + _ -> old -- g, e, z, i + + -- Extract gap start and end from the nibbles of g|e'|z|i' + -- where g is the gap width and e' is 8 minus its end. + finalGap :: Int# -> (Int, Int) + finalGap i = + let g = i `uncheckedIShiftRL#` 12# + in case g <# 2# of + 1# -> (0, 0) + _ -> let e = 8# -# ((i `uncheckedIShiftRL#` 8#) `andI#` 0xf#) + s = e -# g + in (I# s, I# e) +{-# INLINE bestgap #-} diff --git a/iproute.cabal b/iproute.cabal --- a/iproute.cabal +++ b/iproute.cabal @@ -1,5 +1,5 @@ Name: iproute -Version: 1.7.8 +Version: 1.7.9 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -14,11 +14,19 @@ Category: Algorithms, Network Cabal-Version: >= 1.10 Build-Type: Simple +Tested-With: GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.2 Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Data.IP + Data.IP.Builder Data.IP.Internal Data.IP.RouteTable Data.IP.RouteTable.Internal @@ -29,10 +37,13 @@ Build-Depends: base >= 4.6 && < 5 , appar , byteorder + , bytestring , containers , network if impl(ghc < 8.0) Build-Depends: semigroups >= 0.17 + if impl(ghc >= 8) + Default-Extensions: Strict StrictData Test-Suite doctest Type: exitcode-stdio-1.0 @@ -42,6 +53,10 @@ Main-Is: doctests.hs Build-Depends: base >= 4.6 && < 5 , doctest >= 0.9.3 + , appar + , byteorder + , bytestring + , network Test-Suite spec Type: exitcode-stdio-1.0 @@ -50,12 +65,14 @@ Ghc-Options: -Wall Main-Is: Spec.hs Other-Modules: RouteTableSpec + , BuilderSpec , IPSpec Build-Depends: base >= 4.6 && < 5 , hspec , QuickCheck , appar , byteorder + , bytestring , containers , network , safe diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/BuilderSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module BuilderSpec where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif +import Control.Monad +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.IP +import Data.IP.Builder +import Data.IP.RouteTable +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +---------------------------------------------------------------- +-- +-- Arbitrary +-- + +b16, b17 :: Int +b16 = 65535 +b17 = (b16 + 1) * 2 - 1 + +instance Arbitrary IPv4 where + arbitrary = arbitraryAdr toIPv4 255 255 4 + +-- | Bias the IPv6 generator to produce 0s with ~50% probability, so that we +-- stand a non-trivial chance of testing the gap computation corner cases. +-- We also give 0xffff enhanced odds, by choosing that instead of 0 one +-- time out of 16. +-- +instance Arbitrary IPv6 where + arbitrary = arbitraryAdr toIPv6 b16 b17 8 + +arbitraryAdr :: Routable a => ([Int] -> a) -> Int -> Int -> Int -> Gen a +arbitraryAdr func width range adrlen = + func <$> replicateM adrlen biased + where + biased = do + n <- choose(0, range) + if n <= width + then return n + else do + f <- choose (0, 15 :: Int) + if f < 15 + then return 0 + else return width + +---------------------------------------------------------------- +-- +-- Spec +-- + +spec :: Spec +spec = do + describe "test builders" $ do + prop "IPv4 Builder matches Show instance" v4_compat + prop "IPv6 Builder matches Show instance" v6_compat + +v4_compat :: IPv4 -> Bool +v4_compat a = builderToString (ipv4Builder a) == show a + +v6_compat :: IPv6 -> Bool +v6_compat a = builderToString (ipv6Builder a) == show a + +builderToString :: BB.Builder -> String +builderToString = LBSC.unpack . BB.toLazyByteString diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -3,4 +3,9 @@ import Test.DocTest main :: IO () -main = doctest ["-XOverloadedStrings", "Data/IP.hs", "Data/IP/RouteTable.hs"] +main = doctest [ "-XOverloadedStrings" + , "-package=appar" + , "-package=byteorder" + , "-package=network" + , "Data/IP.hs" + , "Data/IP/RouteTable.hs"]