diff --git a/hw-ip.cabal b/hw-ip.cabal --- a/hw-ip.cabal +++ b/hw-ip.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: hw-ip -version: 1.0.0.0 +version: 2.0.0.0 license: BSD3 license-file: LICENSE copyright: 2018 John Ky, David Turnbull, Jian Wan @@ -25,19 +25,30 @@ library exposed-modules: HaskellWorks.Data.Network.Ip - HaskellWorks.Data.Network.Ip.Ip - HaskellWorks.Data.Network.Ip.Ipv6 HaskellWorks.Data.Network.Ip.Internal + HaskellWorks.Data.Network.Ip.Ip HaskellWorks.Data.Network.Ip.Ipv4 - HaskellWorks.Data.Network.Ip.Type + HaskellWorks.Data.Network.Ip.Ipv6 + HaskellWorks.Data.Network.Ip.Range + HaskellWorks.Data.Network.Ip.SafeEnum + HaskellWorks.Data.Network.Ip.Validity + HaskellWorks.Data.Network.Ip.Word128 hs-source-dirs: src other-modules: Paths_hw_ip default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -O2 + -msse4.2 build-depends: base >= 4 && < 4.13 , appar >= 0.1.7 && < 0.2 - , attoparsec >= 0.13.2.2 && < 0.14 + , containers , generic-lens >= 0.5.1.0 && < 1.2 , hw-bits >= 0.7.0.2 && < 0.8 , iproute >= 1.7.3 && < 1.8 @@ -48,13 +59,28 @@ main-is: Spec.hs hs-source-dirs: test other-modules: - HaskellWorks.Data.Network.IpSpec + HaskellWorks.Data.Network.Gen + HaskellWorks.Data.Network.IpBlockSpec + HaskellWorks.Data.Network.Ipv4Spec + HaskellWorks.Data.Network.Ipv6Spec + HaskellWorks.Data.Network.RangeSpec + HaskellWorks.Data.Network.Word128Spec Paths_hw_ip default-language: Haskell2010 - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -O2 + -msse4.2 + -threaded + -rtsopts + -with-rtsopts=-N build-depends: base >= 4 && < 4.13 - , attoparsec + , appar , generic-lens , hedgehog >= 0.5.3 && < 0.7 , hspec >= 2.4.4 && < 2.6 diff --git a/src/HaskellWorks/Data/Network/Ip.hs b/src/HaskellWorks/Data/Network/Ip.hs --- a/src/HaskellWorks/Data/Network/Ip.hs +++ b/src/HaskellWorks/Data/Network/Ip.hs @@ -1,9 +1,1 @@ -module HaskellWorks.Data.Network.Ip - ( module X - ) where - -import HaskellWorks.Data.Network.Ip.Internal as X -import HaskellWorks.Data.Network.Ip.Ip as X -import HaskellWorks.Data.Network.Ip.Ipv4 as X -import HaskellWorks.Data.Network.Ip.Ipv6 as X -import HaskellWorks.Data.Network.Ip.Type as X +module HaskellWorks.Data.Network.Ip where diff --git a/src/HaskellWorks/Data/Network/Ip/Internal.hs b/src/HaskellWorks/Data/Network/Ip/Internal.hs --- a/src/HaskellWorks/Data/Network/Ip/Internal.hs +++ b/src/HaskellWorks/Data/Network/Ip/Internal.hs @@ -6,7 +6,7 @@ import Data.Word import HaskellWorks.Data.Bits.BitWise -import qualified Data.Attoparsec.Text as AP +import qualified Text.Appar.String as AP fourOctetsToWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 fourOctetsToWord32 a b c d = @@ -23,11 +23,11 @@ where paste a b = a * 10 + b octet :: AP.Parser Word8 -octet = (ds 1 2 #<*># d 5 ) #<*># ds 0 5 - <|> (ds 1 2 #<*># ds 0 4) #<*># ds 0 9 - <|> ( d 1 #<*># ds 0 9) #<*># ds 0 9 - <|> ds 1 9 #<*># ds 0 9 - <|> ds 0 9 +octet = AP.try ((digits 1 2 #<*># digit 5 ) #<*># digits 0 5) + <|> AP.try ((digits 1 2 #<*># digits 0 4) #<*># digits 0 9) + <|> AP.try (( digit 1 #<*># digits 0 9) #<*># digits 0 9) + <|> AP.try ( digits 1 9 #<*># digits 0 9) + <|> digits 0 9 whitespace :: AP.Parser () whitespace = void $ many (AP.satisfy isSpace) @@ -40,16 +40,16 @@ <*> octet ipv4NetMask :: AP.Parser Word8 -ipv4NetMask = d 3 #<*># ds 0 2 - <|> d 2 #<*># ds 0 9 - <|> d 1 #<*># ds 0 9 - <|> ds 0 9 +ipv4NetMask = AP.try (digit 3 #<*># digits 0 2) + <|> AP.try (digit 2 #<*># digits 0 9) + <|> AP.try (digit 1 #<*># digits 0 9) + <|> digits 0 9 -d :: Int -> AP.Parser Word8 -d c = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (== chr (c + 48)) +digit :: Int -> AP.Parser Word8 +digit c = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (== chr (c + 48)) -ds :: Int -> Int -> AP.Parser Word8 -ds c1 c2 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= chr (c1 + 48) && c <= chr (c2 + 48)) +digits :: Int -> Int -> AP.Parser Word8 +digits c1 c2 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= chr (c1 + 48) && c <= chr (c2 + 48)) ipv4Block :: AP.Parser (Word32, Word8) ipv4Block = do @@ -60,3 +60,20 @@ word32x4ToWords :: (Word32, Word32, Word32, Word32) -> [Word32] word32x4ToWords (a, b, c, d) = [a, b, c, d] + +bitPower :: Word8 -> Word64 +bitPower m = fromIntegral (32 - m) + +blockSize :: Word8 -> Int +blockSize m = 2 ^ bitPower m + +bitPower128 :: Word8 -> Integer +bitPower128 m = fromIntegral (128 - m) + +blockSize128 :: Word8 -> Integer +blockSize128 m = 2 ^ bitPower128 m + +readsPrecOnParser :: AP.Parser a -> Int -> String -> [(a, String)] +readsPrecOnParser p _ s = case AP.runParser (whitespace *> p) s of + (Just a, r) -> [(a, r)] + _ -> [] diff --git a/src/HaskellWorks/Data/Network/Ip/Ip.hs b/src/HaskellWorks/Data/Network/Ip/Ip.hs --- a/src/HaskellWorks/Data/Network/Ip/Ip.hs +++ b/src/HaskellWorks/Data/Network/Ip/Ip.hs @@ -1,62 +1,62 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} module HaskellWorks.Data.Network.Ip.Ip ( IpBlock(..) - , isValidIpBlock - , firstAddress - , lastAddress + , isCanonical + , canonicalise + , firstIpAddress + , lastIpAddress ) where -import Control.Applicative import Control.Monad -import Data.Char -import Data.Maybe import Data.Word import GHC.Generics import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Network.Ip.Validity import Text.Read -import qualified Data.Attoparsec.Text as AP -import qualified Data.Bits as B -import qualified Data.Text as T -import qualified HaskellWorks.Data.Network.Ip.Internal as I -import qualified HaskellWorks.Data.Network.Ip.Ipv4 as I4 -import qualified HaskellWorks.Data.Network.Ip.Ipv6 as I6 -import qualified Text.ParserCombinators.ReadPrec as RP +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as V4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as V6 -data IpBlock = IpBlockV4 I4.Ipv4Block | IpBlockV6 I6.Ipv6Block +data IpBlock v = IpBlockV4 (V4.IpBlock v) | IpBlockV6 (V6.IpBlock v) deriving (Eq, Ord, Generic) -instance Show IpBlock where +instance Show (IpBlock v) where showsPrec _ (IpBlockV4 a) = shows a showsPrec _ (IpBlockV6 a) = shows a -instance Read IpBlock where +instance Read (IpBlock Unaligned) where readsPrec _ s = - case readMaybe s :: Maybe I4.Ipv4Block of - Just ipv4 -> [(IpBlockV4 ipv4, "")] + case readMaybe s :: Maybe (V4.IpBlock Unaligned) of + Just ip -> [(IpBlockV4 ip, "")] Nothing -> - case readMaybe s :: Maybe I6.Ipv6Block of + case readMaybe s :: Maybe (V6.IpBlock Unaligned) of Just ipv6 -> [(IpBlockV6 ipv6, "")] Nothing -> [] -isValidIpBlock :: IpBlock -> Bool -isValidIpBlock (IpBlockV4 b) = I4.isValidIpv4Block b -isValidIpBlock (IpBlockV6 b) = I6.isValidIpv6Block b +isCanonical :: IpBlock v -> Bool +isCanonical (IpBlockV4 b) = V4.isCanonical b +isCanonical (IpBlockV6 b) = V6.isCanonical b -firstAddress :: IpBlock -> (Word32, Word32, Word32, Word32) -firstAddress (IpBlockV4 i4b) = firstAddress (IpBlockV6 (I6.ipv4BlockToMappedIpv6Block i4b)) -firstAddress (IpBlockV6 (I6.Ipv6Block ip _)) = I6.words ip +canonicalise :: IpBlock Unaligned -> Maybe (IpBlock Canonical) +canonicalise (IpBlockV4 (V4.IpBlock a m)) = mfilter isCanonical (Just $ IpBlockV4 (V4.IpBlock a m)) +canonicalise (IpBlockV6 (V6.IpBlock a m)) = mfilter isCanonical (Just $ IpBlockV6 (V6.IpBlock a m)) -lastAddress :: IpBlock -> (Word32, Word32, Word32, Word32) -lastAddress (IpBlockV4 ib) = (0, 0, 0xFFFF, I4.word (I4.lastIpv4Address ib)) -lastAddress (IpBlockV6 (I6.Ipv6Block ip (I6.Ipv6NetMask msk))) = - let (w1, w2, w3, w4) = I6.words ip - lt = I6.masksIpv6 $ fromIntegral msk +firstIpAddress :: IpBlock Canonical -> (Word32, Word32, Word32, Word32) +firstIpAddress (IpBlockV4 v4Block) = firstIpAddress (IpBlockV6 (V6.fromV4 v4Block)) +-- firstIpAddress (IpBlockV6 (V6.IpBlock ip _)) = V6.words ip +firstIpAddress (IpBlockV6 (V6.IpBlock (V6.IpAddress ip) _)) = ip + +lastIpAddress :: IpBlock Canonical -> (Word32, Word32, Word32, Word32) +lastIpAddress (IpBlockV4 ib) = (0, 0, 0xFFFF, V4.word (V4.lastIpAddress ib)) +lastIpAddress (IpBlockV6 (V6.IpBlock (V6.IpAddress ip) (V6.IpNetMask msk))) = + let (w1, w2, w3, w4) = ip + lt = V6.masksIp $ fromIntegral msk w1' = w1 .|. (lt !! 0) w2' = w2 .|. (lt !! 1) w3' = w3 .|. (lt !! 2) diff --git a/src/HaskellWorks/Data/Network/Ip/Ipv4.hs b/src/HaskellWorks/Data/Network/Ip/Ipv4.hs --- a/src/HaskellWorks/Data/Network/Ip/Ipv4.hs +++ b/src/HaskellWorks/Data/Network/Ip/Ipv4.hs @@ -1,140 +1,203 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} module HaskellWorks.Data.Network.Ip.Ipv4 - ( Ipv4Address(..) - , Ipv4NetMask(..) - , Ipv4Block(..) - , isValidIpv4Block + ( IpAddress(..) + , IpNetMask(..) + , IpBlock(..) , bitPower - , blockSize , isCanonical , splitBlock - , textToMaybeIpv4Address - , parseIpv4Address - , ipv4AddressToString - , ipv4AddressToText - , ipv4AddressToWords - , firstIpv4Address - , lastIpv4Address + , parseIpAddress + , showIpAddress + , showsIpAddress + , tshowIpAddress + , tshowIpBlock + , ipAddressToWords + , firstIpAddress + , lastIpAddress + , canonicaliseIpBlock + , collapseIpBlocks + , splitIpRange + , rangeToBlocksDL + , rangeToBlocks + , blockToRange ) where -import Control.Applicative -import Control.Monad -import Data.Char -import Data.Maybe +import Data.Bifunctor +import Data.Foldable +import Data.Semigroup ((<>)) import Data.Word import GHC.Generics import HaskellWorks.Data.Bits.BitWise -import Text.Read +import HaskellWorks.Data.Network.Ip.Range +import HaskellWorks.Data.Network.Ip.Validity -import qualified Data.Attoparsec.Text as AP import qualified Data.Bits as B +import qualified Data.Sequence as S import qualified Data.Text as T import qualified HaskellWorks.Data.Network.Ip.Internal as I -import qualified Text.ParserCombinators.ReadPrec as RP +import qualified Text.Appar.String as AP -newtype Ipv4Address = Ipv4Address +newtype IpAddress = IpAddress { word :: Word32 - } deriving (Enum, Eq, Ord, Generic) + } deriving (Enum, Bounded, Eq, Ord, Generic) -instance Show Ipv4Address where - showsPrec _ (Ipv4Address w) = - shows ((w .>. 24) .&. 0xff) . ('.':) . - shows ((w .>. 16) .&. 0xff) . ('.':) . - shows ((w .>. 8) .&. 0xff) . ('.':) . - shows ( w .&. 0xff) +instance Show IpAddress where + showsPrec _ = showsIpAddress -instance Read Ipv4Address where - readsPrec :: Int -> String -> [(Ipv4Address, String)] - readsPrec _ s = case AP.parseWith (return mempty) (I.whitespace *> I.ipv4Address) (T.pack s) of - Just result -> case result of - AP.Done i r -> [(Ipv4Address r, T.unpack i)] - AP.Partial _ -> [] - AP.Fail a b c -> [] - Nothing -> [] +instance Read IpAddress where + readsPrec :: Int -> String -> [(IpAddress, String)] + readsPrec = I.readsPrecOnParser (IpAddress <$> I.ipv4Address) -newtype Ipv4NetMask = Ipv4NetMask +newtype IpNetMask = IpNetMask { word8 :: Word8 - } deriving (Enum, Eq, Ord, Show, Generic) + } deriving (Enum, Bounded, Eq, Ord, Show, Generic) -data Ipv4Block = Ipv4Block - { base :: !Ipv4Address - , mask :: !Ipv4NetMask - } deriving (Eq, Ord) +-- | An IP block. The type parameter determines whether or not the value of the type is +-- canonical. +data IpBlock v = IpBlock + { base :: !IpAddress + , mask :: !IpNetMask + } deriving (Eq, Ord, Generic) -instance Show Ipv4Block where - showsPrec _ (Ipv4Block b (Ipv4NetMask m)) = shows b . ('/':) . shows m +instance Show (IpBlock v) where + showsPrec _ = showsIpBlock -instance Read Ipv4Block where - readsPrec :: Int -> String -> [(Ipv4Block, String)] - readsPrec _ s = case AP.parseWith (return mempty) (I.whitespace *> I.ipv4Block) (T.pack s) of - Just result -> case result of - AP.Done i (a, m) -> - case validIpv4Block $ Ipv4Block (Ipv4Address a) (Ipv4NetMask m) of - Just b -> [(b, T.unpack i)] - Nothing -> [] - AP.Partial _ -> [] - AP.Fail a b c -> [] - Nothing -> [] +instance Read (IpBlock Unaligned) where + readsPrec = I.readsPrecOnParser parseUnalignedIpBlock --- shift the address left by the amount of mask bits to reveal only host bits --- if any bits left are non-zero, then the mask is not big enough -validIpv4Block :: Ipv4Block -> Maybe Ipv4Block -validIpv4Block b@(Ipv4Block (Ipv4Address word) (Ipv4NetMask mask)) = - if word `B.shiftL` fromIntegral mask `B.xor` 0 == 0 - then pure b - else Nothing +instance Read (IpBlock Canonical) where + readsPrec = I.readsPrecOnParser parseCanonicalIpBlock -isValidIpv4Block :: Ipv4Block -> Bool -isValidIpv4Block = isJust . validIpv4Block +-- | Canonicalise the block by zero-ing out the host bits +canonicaliseIpBlock :: IpBlock v -> IpBlock Canonical +canonicaliseIpBlock (IpBlock (IpAddress w) (IpNetMask m)) = IpBlock (IpAddress newWord) (IpNetMask m) + where bp = fromIntegral (32 - m) + newWord = (w .>. bp) .<. bp -firstIpv4Address :: Ipv4Block -> Ipv4Address -firstIpv4Address (Ipv4Block base _) = base +firstIpAddress :: IpBlock v -> IpAddress +firstIpAddress (IpBlock b _) = b -lastIpv4Address :: Ipv4Block -> Ipv4Address -lastIpv4Address b@(Ipv4Block (Ipv4Address base) _) = Ipv4Address (base + fromIntegral (blockSize b) - 1) +lastIpAddress :: IpBlock v -> IpAddress +lastIpAddress (IpBlock (IpAddress b) (IpNetMask m)) = IpAddress (b + fromIntegral (I.blockSize m) - 1) -bitPower :: Ipv4NetMask -> Word64 -bitPower (Ipv4NetMask m) = fromIntegral (32 - m) +bitPower :: IpNetMask -> Word64 +bitPower (IpNetMask m) = fromIntegral (32 - m) -isCanonical :: Ipv4Block -> Bool -isCanonical (Ipv4Block (Ipv4Address b) m) = ((b .>. bitPower m) .<. bitPower m) == b +-- | A valid block must have all host-bits set to zero after the mask is applied +isCanonical :: IpBlock v -> Bool +isCanonical (IpBlock (IpAddress b) (IpNetMask m)) = ((b .>. I.bitPower m) .<. I.bitPower m) == b -splitBlock :: Ipv4Block -> Maybe (Ipv4Block, Ipv4Block) -splitBlock (Ipv4Block (Ipv4Address b) (Ipv4NetMask m)) = +splitBlock :: IpBlock Canonical -> Maybe (IpBlock Canonical, IpBlock Canonical) +splitBlock (IpBlock (IpAddress b) (IpNetMask m)) = if m >= 0 && m < 32 then let !hm = m + 1 - !halfMask = Ipv4NetMask hm + !halfMask = IpNetMask hm !c = fromIntegral ((0x100000000 :: Word64) .>. fromIntegral (m + 1)) in Just - ( Ipv4Block (Ipv4Address b ) halfMask - , Ipv4Block (Ipv4Address (b + c)) halfMask + ( IpBlock (IpAddress b ) halfMask + , IpBlock (IpAddress (b + c)) halfMask ) else Nothing -blockSize :: Ipv4Block -> Int -blockSize (Ipv4Block _ m) = 2 ^ bitPower m +showsIpAddress :: IpAddress -> String -> String +showsIpAddress (IpAddress w) = + shows ((w .>. 24) .&. 0xff) . ('.':) . + shows ((w .>. 16) .&. 0xff) . ('.':) . + shows ((w .>. 8) .&. 0xff) . ('.':) . + shows ( w .&. 0xff) -textToMaybeIpv4Address :: T.Text -> Maybe Ipv4Address -textToMaybeIpv4Address t = AP.maybeResult =<< AP.parseWith (return mempty) parseIpv4Address t +showIpAddress :: IpAddress -> String +showIpAddress ipAddress = showsIpAddress ipAddress "" -ipv4AddressToString :: Ipv4Address -> String -ipv4AddressToString = show +tshowIpAddress :: IpAddress -> T.Text +tshowIpAddress = T.pack . showIpAddress -ipv4AddressToText :: Ipv4Address -> T.Text -ipv4AddressToText = T.pack . ipv4AddressToString +showsIpBlock :: IpBlock v -> String -> String +showsIpBlock (IpBlock b (IpNetMask m)) = shows b . ('/':) . shows m -ipv4AddressToWords :: Ipv4Address -> (Word8, Word8, Word8, Word8) -ipv4AddressToWords (Ipv4Address w) = +showIpBlock :: IpBlock v -> String +showIpBlock ipBlock = showsIpBlock ipBlock "" + +tshowIpBlock :: IpBlock v -> T.Text +tshowIpBlock = T.pack . showIpBlock + +ipAddressToWords :: IpAddress -> (Word8, Word8, Word8, Word8) +ipAddressToWords (IpAddress w) = ( fromIntegral (w .>. 24) .&. 0xff , fromIntegral (w .>. 16) .&. 0xff , fromIntegral (w .>. 8) .&. 0xff , fromIntegral (w .&. 0xff) ) -parseIpv4Address :: AP.Parser Ipv4Address -parseIpv4Address = Ipv4Address <$> I.ipv4Address +parseIpAddress :: AP.Parser IpAddress +parseIpAddress = IpAddress <$> I.ipv4Address + +parseUnalignedIpBlock :: AP.Parser (IpBlock Unaligned) +parseUnalignedIpBlock = do + (a, m) <- I.ipv4Block + return (IpBlock (IpAddress a) (IpNetMask m)) + +parseCanonicalIpBlock :: AP.Parser (IpBlock Canonical) +parseCanonicalIpBlock = do + b <- parseUnalignedIpBlock + if isCanonical b + then let IpBlock ip m = b in return (IpBlock ip m) + else fail $ showIpBlock b <> " is not a canonical block" + +splitIpRange :: Range IpAddress -> (IpBlock Canonical, Maybe (Range IpAddress)) +splitIpRange (Range (IpAddress a) (IpAddress z)) = (block, remainder) + where bpOuter = width - B.countLeadingZeros (z + 1 - a) - 1 + bpInner = B.countTrailingZeros ((maxBound .<. fromIntegral bpOuter) .|. a) + block = IpBlock (IpAddress a) (IpNetMask (fromIntegral (width - bpInner))) + hostMask = comp (maxBound .<. fromIntegral bpInner) + remainder = if a + hostMask >= z + then Nothing + else Just (Range (IpAddress (a + hostMask + 1)) (IpAddress z)) + width = B.finiteBitSize a + +-- assume distinct & sorted input +collapseIpBlocks :: [IpBlock Canonical] -> [IpBlock Canonical] +collapseIpBlocks tomerge = + skipOverlapped $ concat $ toList <$> go S.empty tomerge + where + go :: S.Seq (IpBlock Canonical) -> [IpBlock Canonical] -> [S.Seq (IpBlock Canonical)] + go m [] = [m] + go m (b:bs) = + case S.viewr m of + S.EmptyR -> go (m S.|> b) bs + m' S.:> bp -> do + let sp@(IpBlock _ (IpNetMask msk)) = superBlock bp + let sp'@(IpBlock _ (IpNetMask msk')) = superBlock b + if sp == sp' then go m' (sp : bs) + else if msk > msk' then + m : go (S.empty S.|> b) bs + else + go (m S.|> b) bs + superBlock (IpBlock (IpAddress w32) (IpNetMask m)) = + IpBlock (IpAddress (w32 B..&. (0xFFFFFFFF `B.shiftL` fromIntegral (32 - (m - 1))))) (IpNetMask (m - 1)) + skipOverlapped [] = [] + skipOverlapped [b] = [b] + skipOverlapped (b1:b2:bs) = + if lastIpAddress b1 >= lastIpAddress b2 then + skipOverlapped (b1:bs) + else + b1 : skipOverlapped (b2:bs) + +rangeToBlocksDL :: Range IpAddress -> [IpBlock Canonical] -> [IpBlock Canonical] +rangeToBlocksDL r = do + let (b, remainder) = splitIpRange r + case remainder of + Just rmd -> (b:) . rangeToBlocksDL rmd + Nothing -> (b:) + +rangeToBlocks :: Range IpAddress -> [IpBlock Canonical] +rangeToBlocks r = rangeToBlocksDL r [] + +blockToRange :: IpBlock Canonical -> Range IpAddress +blockToRange b = uncurry Range $ bimap firstIpAddress lastIpAddress (b, b) diff --git a/src/HaskellWorks/Data/Network/Ip/Ipv6.hs b/src/HaskellWorks/Data/Network/Ip/Ipv6.hs --- a/src/HaskellWorks/Data/Network/Ip/Ipv6.hs +++ b/src/HaskellWorks/Data/Network/Ip/Ipv6.hs @@ -1,106 +1,131 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module HaskellWorks.Data.Network.Ip.Ipv6 - ( Ipv6Address(..) - , Ipv6NetMask(..) - , Ipv6Block(..) - , ipv4BlockToMappedIpv6Block - , parseIpv6Block - , masksIpv6 - , isValidIpv6Block + ( IpAddress(..) + , IpNetMask(..) + , IpBlock(..) + , fromV4 + , parseIpBlock + , masksIp + , showIpAddress + , showsIpAddress + , tshowIpAddress + , tshowIpBlock + , firstIpAddress + , lastIpAddress + , rangeToBlocks + , rangeToBlocksDL + , blockToRange + , isCanonical + , splitIpRange ) where import Control.Applicative import Control.Monad -import Data.Bits -import Data.Char -import Data.Generics.Product.Any +import Data.Bifunctor import Data.Maybe import Data.Word import GHC.Generics -import Prelude hiding (words) +import HaskellWorks.Data.Network.Ip.Range +import HaskellWorks.Data.Network.Ip.SafeEnum +import HaskellWorks.Data.Network.Ip.Validity +import Prelude hiding (words) import Text.Read -import qualified Data.Attoparsec.Text as AP import qualified Data.Bits as B import qualified Data.IP as D -import qualified Data.String as S import qualified Data.Text as T import qualified HaskellWorks.Data.Network.Ip.Internal as I -import qualified HaskellWorks.Data.Network.Ip.Ipv4 as I4 -import qualified Text.ParserCombinators.ReadPrec as RP +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as V4 +import qualified HaskellWorks.Data.Network.Ip.Word128 as W -newtype Ipv6Address = Ipv6Address - { words :: (Word32, Word32, Word32, Word32) - } deriving (Eq, Ord, Generic) +newtype IpAddress = IpAddress W.Word128 deriving (Eq, Ord, Generic, SafeEnum) -instance Show Ipv6Address where - showsPrec _ (Ipv6Address w) = shows (D.fromHostAddress6 w) +instance Show IpAddress where + showsPrec _ (IpAddress w) = shows (D.fromHostAddress6 w) -instance Read Ipv6Address where - readsPrec :: Int -> String -> [(Ipv6Address, String)] +instance Read IpAddress where + readsPrec :: Int -> String -> [(IpAddress, String)] readsPrec _ s = case readMaybe s :: Maybe D.IPv6 of - Just ip -> [(Ipv6Address (D.toHostAddress6 ip), "")] + Just ip -> [(IpAddress (D.toHostAddress6 ip), "")] Nothing -> [] -newtype Ipv6NetMask = Ipv6NetMask +newtype IpNetMask = IpNetMask { word :: Word8 } deriving (Enum, Eq, Ord, Show, Generic) -instance Read Ipv6NetMask where +instance Read IpNetMask where readsPrec _ s = - case Ipv6NetMask <$> m of + case IpNetMask <$> m of Just maskv6 -> [(maskv6, "")] Nothing -> [] where m = mfilter (\a -> a >= 0 && a <= 128) (readMaybe s) -data Ipv6Block = Ipv6Block - { base :: !Ipv6Address - , mask :: !Ipv6NetMask +data IpBlock v = IpBlock + { base :: !IpAddress + , mask :: !IpNetMask } deriving (Eq, Ord, Generic) -instance Read Ipv6Block where +instance Read (IpBlock Unaligned) where readsPrec _ s = case T.unpack <$> T.split (== '/') (T.pack s) of - [addr, mask] -> - case readMaybe addr :: Maybe Ipv6Address of + [addr, msk] -> + case readMaybe addr :: Maybe IpAddress of Just ipv6 -> - case readMaybe mask of - Just maskv6 -> - let i6b = Ipv6Block ipv6 maskv6 in - [(i6b, "") | isValidIpv6Block i6b] + case readMaybe msk of + Just mskv6 -> + let i6b = IpBlock ipv6 mskv6 in + [(i6b, "") | isCanonical i6b] Nothing -> [] Nothing -> [] _ -> [] -instance Show Ipv6Block where - showsPrec _ (Ipv6Block b (Ipv6NetMask m)) = shows b . ('/':) . shows m +instance Show (IpBlock v) where + showsPrec _ (IpBlock b (IpNetMask m)) = shows b . ('/':) . shows m -parseIpv6Block :: T.Text -> Either T.Text Ipv6Block -parseIpv6Block t = +parseIpBlock :: T.Text -> Either T.Text (IpBlock Unaligned) +parseIpBlock t = case T.unpack <$> T.split (== '/') t of - [addr, mask] -> - case readMaybe addr :: Maybe Ipv6Address of + [addr, msk] -> + case readMaybe addr :: Maybe IpAddress of Just ipv6 -> - case readMaybe mask of - Just maskv6 -> Right $ Ipv6Block ipv6 maskv6 - Nothing -> Left "cannot read mask" + case readMaybe msk of + Just mskv6 -> Right $ IpBlock ipv6 mskv6 + Nothing -> Left "cannot read mask" Nothing -> Left "cannot read addr" _ -> Left "invalid input string" -masksIpv6 :: Word8 -> [Word32] -masksIpv6 m = +showsIpAddress :: IpAddress -> String -> String +showsIpAddress (IpAddress w) = shows (D.fromHostAddress6 w) + +showIpAddress :: IpAddress -> String +showIpAddress ipAddress = showsIpAddress ipAddress "" + +tshowIpAddress :: IpAddress -> T.Text +tshowIpAddress = T.pack . showIpAddress + +showsIpBlock :: IpBlock v -> String -> String +showsIpBlock (IpBlock b (IpNetMask m)) = shows b . ('/':) . shows m + +showIpBlock :: IpBlock v -> String +showIpBlock ipBlock = showsIpBlock ipBlock "" + +tshowIpBlock :: IpBlock v -> T.Text +tshowIpBlock = T.pack . showIpBlock + +masksIp :: Word8 -> [Word32] +masksIp m = let e = 0xFFFFFFFF :: Word32 -- bits: number of bits which should be 1 - maskValue bits = e `shiftR` (32 - bits) in + maskValue bits = e `B.shiftR` (32 - bits) in if m < 32 then [maskValue (32 - fromIntegral m), e, e, e] else if m < 64 then @@ -112,13 +137,43 @@ else [0, 0, 0, 0] -isValidIpv6Block :: Ipv6Block -> Bool -isValidIpv6Block (Ipv6Block b (Ipv6NetMask m)) = - let lt = masksIpv6 m - ipv6 = I.word32x4ToWords (words b) in - ipv6 == zipWith (.&.) ipv6 (zipWith xor ipv6 lt) +isCanonical :: IpBlock v -> Bool +isCanonical (IpBlock (IpAddress w) (IpNetMask m)) = + let lt = masksIp m + ipv6 = I.word32x4ToWords w in + ipv6 == zipWith (B..&.) ipv6 (zipWith B.xor ipv6 lt) -ipv4BlockToMappedIpv6Block :: I4.Ipv4Block -> Ipv6Block -ipv4BlockToMappedIpv6Block (I4.Ipv4Block b m) = +fromV4 :: V4.IpBlock Canonical -> IpBlock v +fromV4 (V4.IpBlock b m) = -- RFC-4291, "IPv4-Mapped IPv6 Address" - Ipv6Block (Ipv6Address (0, 0, 0xFFFF, I4.word b)) (Ipv6NetMask (96 + I4.word8 m)) + IpBlock (IpAddress (0, 0, 0xFFFF, V4.word b)) (IpNetMask (96 + V4.word8 m)) + +firstIpAddress :: IpBlock Canonical -> IpAddress +firstIpAddress (IpBlock b _) = b + +lastIpAddress :: IpBlock Canonical -> IpAddress +lastIpAddress (IpBlock (IpAddress b) (IpNetMask m)) = IpAddress (b + fromIntegral (I.blockSize128 m) - 1) + +splitIpRange :: Range IpAddress -> (IpBlock Canonical, Maybe (Range IpAddress)) +splitIpRange (Range (IpAddress a) (IpAddress z)) = (block, remainder) + where bpOuter = width - B.countLeadingZeros (z + 1 - a) - 1 + bpInner = B.countTrailingZeros ((maxBound `B.shiftL` fromIntegral bpOuter) B..|. a) + block = IpBlock (IpAddress a) (IpNetMask (fromIntegral (width - bpInner))) + hostMask = B.complement (maxBound `B.shiftL` fromIntegral bpInner) + remainder = if a + hostMask >= z + then Nothing + else Just (Range (IpAddress (a + hostMask + 1)) (IpAddress z)) + width = B.finiteBitSize a + +rangeToBlocksDL :: Range IpAddress -> [IpBlock Canonical] -> [IpBlock Canonical] +rangeToBlocksDL r = do + let (b, remainder) = splitIpRange r + case remainder of + Just rmd -> (b:) . rangeToBlocksDL rmd + Nothing -> (b:) + +rangeToBlocks :: Range IpAddress -> [IpBlock Canonical] +rangeToBlocks r = rangeToBlocksDL r [] + +blockToRange :: IpBlock Canonical -> Range IpAddress +blockToRange b = uncurry Range $ bimap firstIpAddress lastIpAddress (b, b) diff --git a/src/HaskellWorks/Data/Network/Ip/Range.hs b/src/HaskellWorks/Data/Network/Ip/Range.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Network/Ip/Range.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Network.Ip.Range where + +import GHC.Generics +import HaskellWorks.Data.Network.Ip.SafeEnum + +import qualified Text.Appar.String as AP + +data Range a = Range + { first :: a + , last :: a + } deriving (Eq, Ord, Show, Generic) + +parseRange :: AP.Parser a -> AP.Parser (Range a) +parseRange pa = Range <$> pa <* AP.string " - " <*> pa + +-- | Merge adjacent ranges if they overlap or are adjacent +mergeRanges :: (SafeEnum a, Ord a) => [Range a] -> [Range a] +mergeRanges (r1@(Range f1 l1):r2@(Range f2 l2):rs) + | boundedSucc l1 >= f2 = mergeRanges (nr:rs) + | otherwise = r1 : mergeRanges (r2:rs) + where nr = Range f1 (max l1 l2) +mergeRanges [r] = [r] +mergeRanges [] = [] diff --git a/src/HaskellWorks/Data/Network/Ip/SafeEnum.hs b/src/HaskellWorks/Data/Network/Ip/SafeEnum.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Network/Ip/SafeEnum.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module HaskellWorks.Data.Network.Ip.SafeEnum + ( SafeEnum(..) + , boundedPred + , boundedSucc + ) where + +import Data.Int +import Data.Maybe +import Data.Word +import HaskellWorks.Data.Network.Ip.Word128 + +class SafeEnum a where + safePred :: a -> Maybe a + safeSucc :: a -> Maybe a + +instance SafeEnum Word where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Word8 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Word16 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Word32 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Word64 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Word128 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Int where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Int8 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Int16 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Int32 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Int64 where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Char where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Bool where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum () where + safePred = defaultSafePred + safeSucc = defaultSafeSucc + +instance SafeEnum Integer where + safePred = Just . pred + safeSucc = Just . succ + +boundedPred :: SafeEnum a => a -> a +boundedPred a = fromMaybe a (safePred a) + +boundedSucc :: SafeEnum a => a -> a +boundedSucc a = fromMaybe a (safeSucc a) + +defaultSafePred :: (Bounded a, Enum a, Eq a) => a -> Maybe a +defaultSafePred v = if v /= minBound then Just (pred v) else Nothing + +defaultSafeSucc :: (Bounded a, Enum a, Eq a) => a -> Maybe a +defaultSafeSucc v = if v /= maxBound then Just (succ v) else Nothing diff --git a/src/HaskellWorks/Data/Network/Ip/Type.hs b/src/HaskellWorks/Data/Network/Ip/Type.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Network/Ip/Type.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE InstanceSigs #-} - -module HaskellWorks.Data.Network.Ip.Type - ( I4.Ipv4Address(..) - , I4.Ipv4NetMask(..) - , I4.Ipv4Block(..) - , I6.Ipv6Address(..) - , I6.Ipv6NetMask(..) - , I6.Ipv6Block(..) - ) where - -import qualified HaskellWorks.Data.Network.Ip.Ipv4 as I4 -import qualified HaskellWorks.Data.Network.Ip.Ipv6 as I6 diff --git a/src/HaskellWorks/Data/Network/Ip/Validity.hs b/src/HaskellWorks/Data/Network/Ip/Validity.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Network/Ip/Validity.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Network.Ip.Validity where + +data Canonical = Canonical + +data Unaligned = Unaligned diff --git a/src/HaskellWorks/Data/Network/Ip/Word128.hs b/src/HaskellWorks/Data/Network/Ip/Word128.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Network/Ip/Word128.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HaskellWorks.Data.Network.Ip.Word128 where + +import Data.Maybe +import Data.Word +import Prelude hiding (words) + +import qualified Data.Bits as B + +type Word128 = (Word32, Word32, Word32, Word32) + +instance Enum Word128 where + fromEnum = fromIntegral . word128ToInteger + toEnum i = integerToWord128 $ fromIntegral i + succ (0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff) = (0, 0, 0, 0) + succ (a, 0xffffffff, 0xffffffff, 0xffffffff) = (succ a, 0, 0, 0) + succ (a, b, 0xffffffff, 0xffffffff) = (a, succ b, 0, 0) + succ (a, b, c, 0xffffffff) = (a, b, succ c, 0) + succ (a, b, c, d) = (a, b, c, succ d) + pred (0, 0, 0, 0) = (0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff) + pred (a, 0, 0, 0) = ( pred a, 0xffffffff, 0xffffffff, 0xffffffff) + pred (a, b, 0, 0) = ( a, pred b, 0xffffffff, 0xffffffff) + pred (a, b, c, 0) = ( a, b, pred c, 0xffffffff) + pred (a, b, c, d) = ( a, b, c, pred d) + +integerToWord128 :: Integer -> Word128 +integerToWord128 i = let a = fromIntegral (i `B.shiftR` 96 B..&. 0xffffffff) + b = fromIntegral (i `B.shiftR` 64 B..&. 0xffffffff) + c = fromIntegral (i `B.shiftR` 32 B..&. 0xffffffff) + d = fromIntegral (i `B.shiftR` 00 B..&. 0xffffffff) + in (a, b, c, d) + +word128ToInteger :: Word128 -> Integer +word128ToInteger (a, b, c, d) = let a' = fromIntegral a `B.shift` 96 + b' = fromIntegral b `B.shift` 64 + c' = fromIntegral c `B.shift` 32 + d' = fromIntegral d `B.shift` 0 + in a' B..|. b' B..|. c' B..|. d' :: Integer + +instance Num Word128 where + (+) l r = integerToWord128 $ (word128ToInteger l) + (word128ToInteger r) + (-) l r = integerToWord128 $ (word128ToInteger l) - (word128ToInteger r) + (*) l r = integerToWord128 $ (word128ToInteger l) * (word128ToInteger r) + abs a = a + signum (0, 0, 0, 0) = minBound + signum _ = 1 + fromInteger = integerToWord128 + +instance B.Bits Word128 where + (.&.) (a, b, c, d) (e, f, g, h) = (a B..&. e, b B..&. f, c B..&. g, d B..&. h) + (.|.) (a, b, c, d) (e, f, g, h) = (a B..|. e, b B..|. f, c B..|. g, d B..|. h) + xor (a, b, c, d) (e, f, g, h) = (a `B.xor` e, b `B.xor` f, c `B.xor` g, d `B.xor` h) + complement (a, b, c, d) = (B.complement a, B.complement b, B.complement c, B.complement d) + shift w n = integerToWord128 $ word128ToInteger w `B.shift` n + shiftL w n + | n < 0 = minBound -- This is the special case to make it behaviour as the same as Word32 + | otherwise = integerToWord128 $ word128ToInteger w `B.shiftL` n + shiftR w n = integerToWord128 $ word128ToInteger w `B.shiftR` n + rotate w n = integerToWord128 $ word128ToInteger w `B.rotate` n + rotateL w n = integerToWord128 $ word128ToInteger w `B.rotateL` n + rotateR w n = integerToWord128 $ word128ToInteger w `B.rotateR` n + bitSize _ = 128 + bitSizeMaybe _ = Just 128 + isSigned _ = False + testBit w = B.testBit (word128ToInteger w) + bit n = integerToWord128 $ B.bit n + popCount w = B.popCount $ word128ToInteger w + +instance B.FiniteBits Word128 where + finiteBitSize _ = 128 diff --git a/test/HaskellWorks/Data/Network/Gen.hs b/test/HaskellWorks/Data/Network/Gen.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/Gen.hs @@ -0,0 +1,31 @@ +module HaskellWorks.Data.Network.Gen + ( canonicalIpv4Block + , canonicalIpv6Block + ) where + +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Network.Ip.Validity +import Hedgehog + +import qualified Data.Bits as B +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as V4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as V6 +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +canonicalIpv4Block :: MonadGen m => m (V4.IpBlock Canonical) +canonicalIpv4Block = do + m <- G.word8 (R.linear 0 32) + let p = fromIntegral (32 - m) + w <- G.word32 (R.linear 0 ((0xffffffff .>. p) .<. p)) + return (V4.IpBlock (V4.IpAddress (w .<. p)) (V4.IpNetMask m)) + +canonicalIpv6Block :: MonadGen m => m (V6.IpBlock Canonical) +canonicalIpv6Block = do + m <- G.word8 (R.linear 0 128) + let p = fromIntegral (128 - m) + w128 <- (,,,) <$> G.word32 (R.linear 0 0xffffffff) + <*> G.word32 (R.linear 0 0xffffffff) + <*> G.word32 (R.linear 0 0xffffffff) + <*> G.word32 (R.linear 0 0xffffffff) + return (V6.IpBlock (V6.IpAddress (w128 `B.shift` p)) (V6.IpNetMask m)) diff --git a/test/HaskellWorks/Data/Network/IpBlockSpec.hs b/test/HaskellWorks/Data/Network/IpBlockSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/IpBlockSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Data.Network.IpBlockSpec (spec) where + +import HaskellWorks.Data.Network.Ip.Validity +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified HaskellWorks.Data.Network.Ip.Ip as V +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as V6 + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Network.IpSpec" $ do + describe "IpBlock" $ do + it "should implement show" $ requireTest $ do + show (V.IpBlockV6 @Unaligned (V6.IpBlock (V6.IpAddress (3, 3, 3, 0)) (V6.IpNetMask 96))) === "0:3:0:3:0:3::/96" + + it "should implement read" $ requireTest $ do + read "1:2:3:4::/127" === V.IpBlockV6 @Unaligned (V6.IpBlock (V6.IpAddress (0x10002 , 0x30004 , 0, 0)) (V6.IpNetMask 127)) + read "1234::/16" === V.IpBlockV6 @Unaligned (V6.IpBlock (V6.IpAddress (0x12340000 , 0 , 0, 0)) (V6.IpNetMask 16)) + read "12:34::/32" === V.IpBlockV6 @Unaligned (V6.IpBlock (V6.IpAddress (0x120034 , 0 , 0, 0)) (V6.IpNetMask 32)) diff --git a/test/HaskellWorks/Data/Network/IpSpec.hs b/test/HaskellWorks/Data/Network/IpSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Network/IpSpec.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Network.IpSpec (spec) where - -import HaskellWorks.Data.Network.Ip -import HaskellWorks.Data.Network.Ip.Ipv4 -import HaskellWorks.Data.Network.Ip.Internal -import HaskellWorks.Hspec.Hedgehog -import Hedgehog -import Test.Hspec - -import qualified Data.Attoparsec.Text as AP -import qualified Text.Read as TR -import qualified Data.Text as T -import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} - -spec :: Spec -spec = describe "HaskellWorks.HUnit.IpSpec" $ do - describe "octet" $ do - it "should go from 0-255" $ require $ property $ do - b <- forAll $ G.word8 R.constantBounded - AP.parseOnly octet (T.pack . show $ b) === Right b - - describe "Ipv4Address" $ do - it "should implement show" $ requireTest $ do - show (Ipv4Address 0x000000ff) === "0.0.0.255" - show (Ipv4Address 0x0000ff00) === "0.0.255.0" - show (Ipv4Address 0x00ff0000) === "0.255.0.0" - show (Ipv4Address 0xff000000) === "255.0.0.0" - - it "should implement read" $ requireTest $ do - read "1.2.3.4" === Ipv4Address 0x01020304 - read "10.20.30.40" === Ipv4Address 0x0a141e28 - read "1.2.3.12" === Ipv4Address 0x0102030c - read "1.2.3.160" === Ipv4Address 0x010203a0 - - it "should be possible to extract the octets" $ requireTest $ do - ipv4AddressToWords (Ipv4Address 0x01020304) === (1, 2, 3, 4) - - describe "Ipv4Block" $ do - it "should implement show" $ requireTest $ do - show (Ipv4Block (Ipv4Address 0x000000ff) (Ipv4NetMask 32)) === "0.0.0.255/32" - show (Ipv4Block (Ipv4Address 0x0000ff00) (Ipv4NetMask 32)) === "0.0.255.0/32" - show (Ipv4Block (Ipv4Address 0x00ff0000) (Ipv4NetMask 32)) === "0.255.0.0/32" - show (Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 32)) === "255.0.0.0/32" - show (Ipv4Block (Ipv4Address 0x000000ff) (Ipv4NetMask 16)) === "0.0.0.255/16" - show (Ipv4Block (Ipv4Address 0x0000ff00) (Ipv4NetMask 16)) === "0.0.255.0/16" - show (Ipv4Block (Ipv4Address 0x00ff0000) (Ipv4NetMask 16)) === "0.255.0.0/16" - show (Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 16)) === "255.0.0.0/16" - show (firstIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 8)) === "255.0.0.0" - show (lastIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 8)) === "255.255.255.255" - show (firstIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 16)) === "255.0.0.0" - show (lastIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 16)) === "255.0.255.255" - show (firstIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 24)) === "255.0.0.0" - show (lastIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 24)) === "255.0.0.255" - show (firstIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 32)) === "255.0.0.0" - show (lastIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 32)) === "255.0.0.0" - show (firstIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 21)) === "255.0.0.0" - show (lastIpv4Address $ Ipv4Block (Ipv4Address 0xff000000) (Ipv4NetMask 21)) === "255.0.7.255" - - it "should implement read" $ requireTest $ do - read "1.0.0.0/8" === Ipv4Block (Ipv4Address 0x01000000) (Ipv4NetMask 8) - read "1.2.0.0/16" === Ipv4Block (Ipv4Address 0x01020000) (Ipv4NetMask 16) - read "1.2.3.4/32" === Ipv4Block (Ipv4Address 0x01020304) (Ipv4NetMask 32) - - it "should implement splitBlock" $ requireTest $ do - splitBlock (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 32)) === Nothing - splitBlock (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 31)) === Just (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 32), Ipv4Block (Ipv4Address 0x00000001) (Ipv4NetMask 32)) - splitBlock (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 30)) === Just (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 31), Ipv4Block (Ipv4Address 0x00000002) (Ipv4NetMask 31)) - splitBlock (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 0)) === Just (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 1), Ipv4Block (Ipv4Address 0x80000000) (Ipv4NetMask 1)) - - it "should implement blockSize" $ requireTest $ do - blockSize (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 32)) === 1 - blockSize (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 0)) === 0x100000000 - - it "should validate masks" $ requireTest $ do - (TR.readMaybe "1.2.3.4/8" :: Maybe Ipv4Block) === Nothing - (TR.readMaybe "1.2.3.4/0" :: Maybe Ipv4Block) === Nothing - (TR.readMaybe "1.2.3.4/32" :: Maybe Ipv4Block) === (Just $ Ipv4Block (Ipv4Address 0x01020304) (Ipv4NetMask 32)) diff --git a/test/HaskellWorks/Data/Network/Ipv4Spec.hs b/test/HaskellWorks/Data/Network/Ipv4Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/Ipv4Spec.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Data.Network.Ipv4Spec (spec) where + +import HaskellWorks.Data.Network.Ip.Internal +import HaskellWorks.Data.Network.Ip.Ipv4 +import HaskellWorks.Data.Network.Ip.Range +import HaskellWorks.Data.Network.Ip.Validity +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.List as DL +import qualified HaskellWorks.Data.Network.Gen as G +import qualified HaskellWorks.Data.Network.Ip.Internal as I +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as I +import qualified HaskellWorks.Data.Network.Ip.Range as I +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R +import qualified Text.Appar.String as AP + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Network.Ipv4Spec" $ do + describe "octet" $ do + it "should go from 0-255" $ require $ property $ do + b <- forAll $ G.word8 R.constantBounded + AP.runParser octet (show b) === (Just b, "") + + describe "I.IpAddress" $ do + it "should implement show" $ requireTest $ do + show (I.IpAddress 0x000000ff) === "0.0.0.255" + show (I.IpAddress 0x0000ff00) === "0.0.255.0" + show (I.IpAddress 0x00ff0000) === "0.255.0.0" + show (I.IpAddress 0xff000000) === "255.0.0.0" + + it "should implement read" $ requireTest $ do + read "1.2.3.4" === I.IpAddress 0x01020304 + read "10.20.30.40" === I.IpAddress 0x0a141e28 + read "1.2.3.12" === I.IpAddress 0x0102030c + read "1.2.3.160" === I.IpAddress 0x010203a0 + + it "should be possible to extract the octets" $ requireTest $ do + I.ipAddressToWords (I.IpAddress 0x01020304) === (1, 2, 3, 4) + + describe "I.IpBlock" $ do + it "should implement show" $ requireTest $ do + show (I.IpBlock (I.IpAddress 0x000000ff) (I.IpNetMask 32)) === "0.0.0.255/32" + show (I.IpBlock (I.IpAddress 0x0000ff00) (I.IpNetMask 32)) === "0.0.255.0/32" + show (I.IpBlock (I.IpAddress 0x00ff0000) (I.IpNetMask 32)) === "0.255.0.0/32" + show (I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 32)) === "255.0.0.0/32" + show (I.IpBlock (I.IpAddress 0x000000ff) (I.IpNetMask 16)) === "0.0.0.255/16" + show (I.IpBlock (I.IpAddress 0x0000ff00) (I.IpNetMask 16)) === "0.0.255.0/16" + show (I.IpBlock (I.IpAddress 0x00ff0000) (I.IpNetMask 16)) === "0.255.0.0/16" + show (I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 16)) === "255.0.0.0/16" + show (I.firstIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 8)) === "255.0.0.0" + show (I.lastIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 8)) === "255.255.255.255" + show (I.firstIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 16)) === "255.0.0.0" + show (I.lastIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 16)) === "255.0.255.255" + show (I.firstIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 24)) === "255.0.0.0" + show (I.lastIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 24)) === "255.0.0.255" + show (I.firstIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 32)) === "255.0.0.0" + show (I.lastIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 32)) === "255.0.0.0" + show (I.firstIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 21)) === "255.0.0.0" + show (I.lastIpAddress $ I.IpBlock (I.IpAddress 0xff000000) (I.IpNetMask 21)) === "255.0.7.255" + + it "should implement read" $ requireTest $ do + read "1.0.0.0/8" === I.IpBlock @Unaligned (I.IpAddress 0x01000000) (I.IpNetMask 8) + read "1.2.0.0/16" === I.IpBlock @Unaligned (I.IpAddress 0x01020000) (I.IpNetMask 16) + read "1.2.3.4/32" === I.IpBlock @Unaligned (I.IpAddress 0x01020304) (I.IpNetMask 32) + + it "should implement splitBlock" $ requireTest $ do + I.splitBlock (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 32)) === Nothing + I.splitBlock (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 31)) === Just (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 32), I.IpBlock (I.IpAddress 0x00000001) (I.IpNetMask 32)) + I.splitBlock (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 30)) === Just (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 31), I.IpBlock (I.IpAddress 0x00000002) (I.IpNetMask 31)) + I.splitBlock (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 0)) === Just (I.IpBlock (I.IpAddress 0x00000000) (I.IpNetMask 1), I.IpBlock (I.IpAddress 0x80000000) (I.IpNetMask 1)) + + it "should implement blockSize" $ requireTest $ do + I.blockSize 32 === 0x000000001 + I.blockSize 0 === 0x100000000 + + it "should validate masks" $ requireTest $ do + (read "1.2.3.4/8" :: I.IpBlock Unaligned) === I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 8) + (read "1.2.3.4/0" :: I.IpBlock Unaligned) === I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 0) + (read "1.2.3.4/32" :: I.IpBlock Unaligned) === I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 32) + + it "should canonicalise block" $ requireTest $ do + I.canonicaliseIpBlock (I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 32)) === I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 32) + I.canonicaliseIpBlock (I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 24)) === I.IpBlock (I.IpAddress 0x01020300) (I.IpNetMask 24) + I.canonicaliseIpBlock (I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 16)) === I.IpBlock (I.IpAddress 0x01020000) (I.IpNetMask 16) + I.canonicaliseIpBlock (I.IpBlock (I.IpAddress 0x01020304) (I.IpNetMask 8)) === I.IpBlock (I.IpAddress 0x01000000) (I.IpNetMask 8) + + it "should collapse blocks" $ requireTest $ do + let ipblocks1 = read @(IpBlock Canonical) <$> ["1.2.3.4/32", "4.3.2.1/32"] + collapseIpBlocks ipblocks1 === ipblocks1 + let ipblocks2 = read @(IpBlock Canonical) <$> ["1.2.3.3/32", "1.2.3.0/32", "1.2.3.1/32", "1.2.3.2/32"] + collapseIpBlocks (DL.sort ipblocks2) === (read @(IpBlock Canonical) <$> ["1.2.3.0/30"]) + let ipblocks3 = read @(IpBlock Canonical) <$> ["1.2.3.3/32", "1.2.3.0/32", "1.2.3.1/32", "1.2.3.2/32", "5.5.5.5/32"] + collapseIpBlocks (DL.sort ipblocks3) === (read @(IpBlock Canonical) <$> ["1.2.3.0/30", "5.5.5.5/32"]) + + describe "should split ranges" $ do + it "0.0.0.0 - 0.0.0.0" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.0" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 32), Nothing) + it "0.0.0.1 - 0.0.0.1" $ requireTest $ do + let ip1 = read "0.0.0.1" :: I.IpAddress + let ip2 = read "0.0.0.1" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 32), Nothing) + it "0.0.0.0 - 0.0.0.1" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.1" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 31), Nothing) + it "0.0.0.0 - 0.0.0.2" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.2" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 31), Just (Range ip2 ip2)) + it "0.0.0.0 - 0.0.0.3" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.3" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 30), Nothing) + it "0.0.0.0 - 0.0.0.4" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.4" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 30), Just (Range ip2 ip2)) + it "0.0.0.0 - 0.0.0.5" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.4" :: I.IpAddress + let ip3 = read "0.0.0.5" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 30), Just (Range ip2 ip3)) + it "0.0.0.0 - 0.0.0.5" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.4" :: I.IpAddress + let ip3 = read "0.0.0.6" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 30), Just (Range ip2 ip3)) + it "0.0.0.0 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 29), Nothing) + it "0.0.0.1 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.1" :: I.IpAddress + let ip2 = read "0.0.0.2" :: I.IpAddress + let ip3 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 32), Just (Range ip2 ip3)) + it "0.0.0.2 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.2" :: I.IpAddress + let ip2 = read "0.0.0.4" :: I.IpAddress + let ip3 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 31), Just (Range ip2 ip3)) + it "0.0.0.3 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.3" :: I.IpAddress + let ip2 = read "0.0.0.4" :: I.IpAddress + let ip3 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 32), Just (Range ip2 ip3)) + it "0.0.0.4 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.4" :: I.IpAddress + let ip2 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 30), Nothing) + it "0.0.0.5 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.5" :: I.IpAddress + let ip2 = read "0.0.0.6" :: I.IpAddress + let ip3 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip3) === (I.IpBlock ip1 (I.IpNetMask 32), Just (Range ip2 ip3)) + it "0.0.0.6 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.6" :: I.IpAddress + let ip2 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 31), Nothing) + it "0.0.0.7 - 0.0.0.7" $ requireTest $ do + let ip1 = read "0.0.0.7" :: I.IpAddress + I.splitIpRange (Range ip1 ip1) === (I.IpBlock ip1 (I.IpNetMask 32), Nothing) + it "0.0.0.6 - 0.0.0.6" $ requireTest $ do + let ip1 = read "0.0.0.6" :: I.IpAddress + I.splitIpRange (Range ip1 ip1) === (I.IpBlock ip1 (I.IpNetMask 32), Nothing) + it "255.255.255.255 - 255.255.255.255" $ requireTest $ do + let ip1 = read "255.255.255.255" :: I.IpAddress + I.splitIpRange (Range ip1 ip1) === (I.IpBlock ip1 (I.IpNetMask 32), Nothing) + it "128.0.0.0 - 255.255.255.255" $ requireTest $ do + let ip1 = read "128.0.0.0" :: I.IpAddress + let ip2 = read "255.255.255.255" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 1), Nothing) + it "0.0.0.0 - 255.255.255.255" $ requireTest $ do + let ip1 = read "0.0.0.0" :: I.IpAddress + let ip2 = read "255.255.255.255" :: I.IpAddress + I.splitIpRange (Range ip1 ip2) === (I.IpBlock ip1 (I.IpNetMask 0), Nothing) + + describe "should get blocks from ranges" $ do + it "0.0.0.1 - 0.0.0.2" $ requireTest $ do + I.rangeToBlocks (I.Range (I.IpAddress 0x000001) (I.IpAddress 0x000002)) === [ I.IpBlock (I.IpAddress 0x000001) (I.IpNetMask 32) + , I.IpBlock (I.IpAddress 0x000002) (I.IpNetMask 32)] + it "102.36.48.28 - 102.36.48.255" $ requireTest $ do + I.rangeToBlocks (I.Range (I.IpAddress 0x6624301c) (I.IpAddress 0x662430ff)) === [ I.IpBlock (I.IpAddress 0x6624301c) (I.IpNetMask 30) + , I.IpBlock (I.IpAddress 0x66243020) (I.IpNetMask 27) + , I.IpBlock (I.IpAddress 0x66243040) (I.IpNetMask 26) + , I.IpBlock (I.IpAddress 0x66243080) (I.IpNetMask 25)] + + it "102.36.48.2 - 102.36.48.8" $ requireTest $ do + I.rangeToBlocks (I.Range (I.IpAddress 0x66243002) (I.IpAddress 0x66243008)) === [ I.IpBlock (I.IpAddress 0x66243002) (I.IpNetMask 31) + , I.IpBlock (I.IpAddress 0x66243004) (I.IpNetMask 30) + , I.IpBlock (I.IpAddress 0x66243008) (I.IpNetMask 32)] + + describe "should get blocks from ranges with difference lists" $ do + it "0.0.0.1 - 0.0.0.2" $ requireTest $ do + I.rangeToBlocksDL (I.Range (I.IpAddress 0x000001) (I.IpAddress 0x000002)) [] === [ I.IpBlock (I.IpAddress 0x000001) (I.IpNetMask 32) + , I.IpBlock (I.IpAddress 0x000002) (I.IpNetMask 32)] + + it "block can be converted to range and back" $ require $ property $ do + b <- forAll G.canonicalIpv4Block + I.splitIpRange (I.blockToRange b) === (b, Nothing) diff --git a/test/HaskellWorks/Data/Network/Ipv6Spec.hs b/test/HaskellWorks/Data/Network/Ipv6Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/Ipv6Spec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Data.Network.Ipv6Spec (spec) where + +import HaskellWorks.Data.Network.Ip.SafeEnum +import HaskellWorks.Data.Network.Ip.Validity +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + + +import qualified Data.Text as T +import qualified HaskellWorks.Data.Network.Gen as G +import qualified HaskellWorks.Data.Network.Ip.Ip as V +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as V4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as V6 +import qualified HaskellWorks.Data.Network.Ip.Range as R +import qualified HaskellWorks.Data.Network.Ip.Range as IR + +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Network.Ipv6Spec" $ do + describe "V6.IpBlock" $ do + it "should implement show" $ requireTest $ do + show (V6.IpBlock (V6.IpAddress (3, 3, 3, 0)) (V6.IpNetMask 96)) === "0:3:0:3:0:3::/96" + + it "should implement firstAddress/lastAddress" $ requireTest $ do + V.firstIpAddress (V.IpBlockV4 (V4.IpBlock (V4.IpAddress 0xff000000) (V4.IpNetMask 8))) === (0, 0, 0xFFFF, 0xFF000000) + V.firstIpAddress (V.IpBlockV6 (V6.IpBlock (V6.IpAddress (4, 4, 0, 0)) (V6.IpNetMask 33))) === (4, 4, 0, 0) + V.lastIpAddress (V.IpBlockV4 (V4.IpBlock (V4.IpAddress 0xff000000) (V4.IpNetMask 8))) === (0 , 0 , 0xFFFF , 0xFFFFFFFF) + V.lastIpAddress (V.IpBlockV6 (V6.IpBlock (V6.IpAddress (4, 4, 0, 0)) (V6.IpNetMask 33))) === (4 , 0x7FFFFFFF , 0xFFFFFFFF , 0xFFFFFFFF) + + it "should implement read" $ requireTest $ do + read "1:2:3:4::" === V6.IpAddress (0x10002,0x30004,0,0) + read "1:2:3:4::/127" === V6.IpBlock @Unaligned (V6.IpAddress (0x10002 , 0x30004 , 0, 0)) (V6.IpNetMask 127) + read "1234::/16" === V6.IpBlock @Unaligned (V6.IpAddress (0x12340000, 0 , 0, 0)) (V6.IpNetMask 16) + read "12:34::/32" === V6.IpBlock @Unaligned (V6.IpAddress (0x120034 , 0 , 0, 0)) (V6.IpNetMask 32) + + it "should parse what it has shown" $ require $ property $ do + a <- forAll $ G.word32 R.constantBounded + m <- forAll $ G.word8 $ R.linear 0 128 + let addr = V6.IpBlock (V6.IpAddress (a, 0, 0, 0)) (V6.IpNetMask m) + V6.parseIpBlock (T.pack (show addr)) === Right addr + + it "should support enum" $ require $ property $ do + boundedPred (V6.IpAddress (32, 32, 32, 32)) === V6.IpAddress (32, 32, 32, 31) + boundedSucc (V6.IpAddress (32, 32, 32, 32)) === V6.IpAddress (32, 32, 32, 33) + boundedPred (V6.IpAddress (0, 0, 0, 0xffffffff)) === V6.IpAddress (0, 0, 0, 0xfffffffe) + boundedSucc (V6.IpAddress (0, 0, 0, 0xffffffff)) === V6.IpAddress (0, 0, 1, 0) + boundedSucc (V6.IpAddress maxBound ) === V6.IpAddress maxBound + boundedPred (V6.IpAddress (0, 0, 0, 0)) === V6.IpAddress (0, 0, 0, 0) + + it "should convert ::/128 to ranges" $ requireTest $ do + V6.blockToRange (V6.IpBlock (V6.IpAddress (0, 0, 0, 0)) (V6.IpNetMask 128)) === R.Range (V6.IpAddress (0, 0, 0, 0)) (V6.IpAddress (0, 0, 0, 0)) + + it "should convert 1234::/64 to ranges" $ requireTest $ do + V6.blockToRange (V6.IpBlock (V6.IpAddress (0x12340000, 0, 0, 0)) (V6.IpNetMask 64)) === R.Range (V6.IpAddress (0x12340000, 0, 0, 0)) (V6.IpAddress (0x12340000, 0, 0xffffffff, 0xffffffff)) + + it "block can be converted to range" $ require $ property $ do + let b = V6.IpBlock (V6.IpAddress (0x12340000, 0, 0, 0)) (V6.IpNetMask 16) + V6.blockToRange b === IR.Range (read "1234::") (read "1234:ffff:ffff:ffff:ffff:ffff:ffff:ffff") + + it "block can be converted to range and back" $ require $ property $ do + b <- forAll G.canonicalIpv6Block + V6.splitIpRange (V6.blockToRange b) === (b, Nothing) + + it "ranges can be split" $ require $ property $ do + V6.splitIpRange (IR.Range (read "::") (read "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff")) === (V6.IpBlock (V6.IpAddress (0, 0, 0, 0)) (V6.IpNetMask 0), Nothing) + V6.splitIpRange (IR.Range (read "::") (read "::88")) === (V6.IpBlock (V6.IpAddress (0, 0, 0, 0)) (V6.IpNetMask 121), Just (IR.Range (read "::80") (read "::88"))) + V6.splitIpRange (IR.Range (read "::3") (read "::88")) === (V6.IpBlock (V6.IpAddress (0, 0, 0, 3)) (V6.IpNetMask 128), Just (IR.Range (read "::4") (read "::88"))) + V6.splitIpRange (IR.Range (read "::127") (read "::129")) === (V6.IpBlock (V6.IpAddress (0, 0, 0, 0x127)) (V6.IpNetMask 128), Just (IR.Range (read "::128") (read "::129"))) + + describe "should get blocks from ranges" $ do + it ":: - ::ff" $ requireTest $ do + V6.rangeToBlocks (R.Range (V6.IpAddress 0) (V6.IpAddress 0xff)) === [ V6.IpBlock (V6.IpAddress 0) (V6.IpNetMask 120)] + it "::fe - ::18e" $ requireTest $ do + V6.rangeToBlocks (R.Range (V6.IpAddress 0xfe) (V6.IpAddress 0x18e)) === [ V6.IpBlock (V6.IpAddress 0xfe) (V6.IpNetMask 127) + , V6.IpBlock (V6.IpAddress 0x100) (V6.IpNetMask 121) + , V6.IpBlock (V6.IpAddress 0x180) (V6.IpNetMask 125) + , V6.IpBlock (V6.IpAddress 0x188) (V6.IpNetMask 126) + , V6.IpBlock (V6.IpAddress 0x18c) (V6.IpNetMask 127) + , V6.IpBlock (V6.IpAddress 0x18e) (V6.IpNetMask 128) + ] + it ":: - ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" $ requireTest $ do + V6.rangeToBlocks (R.Range (V6.IpAddress 0) (V6.IpAddress maxBound)) === [ V6.IpBlock (V6.IpAddress 0) (V6.IpNetMask 0)] + + describe "should get blocks from ranges with difference lists" $ do + it "::100 - ::200" $ requireTest $ do + V6.rangeToBlocksDL (R.Range (V6.IpAddress 0x100) (V6.IpAddress 0x200)) [] === [ V6.IpBlock (V6.IpAddress 0x100) (V6.IpNetMask 120) + , V6.IpBlock (V6.IpAddress 0x200) (V6.IpNetMask 128)] diff --git a/test/HaskellWorks/Data/Network/RangeSpec.hs b/test/HaskellWorks/Data/Network/RangeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/RangeSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Data.Network.RangeSpec (spec) where + +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as V6 +import qualified HaskellWorks.Data.Network.Ip.Range as R +import qualified Text.Appar.String as AP + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Network.RangeSpec" $ do + describe "Range" $ do + it "should be mergeable" $ requireTest $ do + R.mergeRanges [] === ([] :: [R.Range Int]) + R.mergeRanges @Int [R.Range 0 5] === [R.Range 0 5] + R.mergeRanges @Int [R.Range 3 5, R.Range 6 7] === [R.Range 3 7] + R.mergeRanges @Int [R.Range 0 5, R.Range 7 7] === [R.Range 0 5, R.Range 7 7] + R.mergeRanges [R.Range 'a' 'b', R.Range 'c' 'f'] === [R.Range 'a' 'f'] + R.mergeRanges [R.Range 'a' 'a', R.Range 'a' 'f'] === [R.Range 'a' 'f'] + R.mergeRanges [R.Range 'a' 'b', R.Range 'b' 'b'] === [R.Range 'a' 'b'] + R.mergeRanges [R.Range 'a' 'f', R.Range 'c' 'e'] === [R.Range 'a' 'f'] + R.mergeRanges [R.Range 'a' 'f', R.Range 'c' 'e', R.Range 'x' 'z'] === [R.Range 'a' 'f', R.Range 'x' 'z'] + + let v6Ranges1 = [ R.Range (V6.IpAddress (0, 0, 0, 0)) (V6.IpAddress (0, 0, 0, 20)) + , R.Range (V6.IpAddress (0, 0, 0, 21)) (V6.IpAddress (0, 0, 0, 0xffffffff)) + , R.Range (V6.IpAddress (0, 0, 1, 0)) (V6.IpAddress (0, 0, 1, 200)) + ] + let v6Ranges2 = [ R.Range (V6.IpAddress (0, 0, 0, 0)) (V6.IpAddress (0, 0, 1, 200)) + ] + R.mergeRanges v6Ranges1 === v6Ranges2 + + it "should parse dash-delimited ranges" $ requireTest $ do + AP.runParser (AP.try (R.parseRange AP.alphaNum)) "a b" === (Nothing , "a b") + AP.runParser (AP.try (R.parseRange AP.alphaNum)) "a - b" === (Just (R.Range 'a' 'b'), "" ) diff --git a/test/HaskellWorks/Data/Network/Word128Spec.hs b/test/HaskellWorks/Data/Network/Word128Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Network/Word128Spec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Network.Word128Spec (spec) where + +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.Bits as B +import qualified HaskellWorks.Data.Network.Ip.Word128 as W + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Network.Ipv6Spec" $ do + describe "Word128" $ do + it "should implement +" $ requireTest $ do + ((1, 1, 1, 1) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) === ((2, 2, 2, 2) :: W.Word128) + ((1, 1, 1, 0xffffffff) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) === ((2, 2, 3, 0) :: W.Word128) + (maxBound :: W.Word128) + ((0, 0, 0, 1) :: W.Word128) === ((0, 0, 0, 0) :: W.Word128) + + it "should implement -" $ requireTest $ do + ((1, 1, 1, 1) :: W.Word128) - ((1, 1, 1, 1) :: W.Word128) === ((0, 0, 0, 0) :: W.Word128) + ((1, 1, 1, 0xffffffff) :: W.Word128) - ((1, 1, 1, 1) :: W.Word128) === ((0, 0, 0, 0xfffffffe) :: W.Word128) + ((0, 0, 0, 1) :: W.Word128) - (maxBound :: W.Word128) === ((0, 0, 0, 2) :: W.Word128) + + it "should implement *" $ requireTest $ do + ((0, 0, 0, 0) :: W.Word128) * ((1, 1, 1, 1) :: W.Word128) === ((0, 0, 0, 0) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) * ((1, 1, 1, 1) :: W.Word128) === ((4, 3, 2, 1) :: W.Word128) + ((1, 1, 1, 0xffffffff) :: W.Word128) * ((0, 0, 0, 1) :: W.Word128) === ((1, 1, 1, 0xffffffff) :: W.Word128) + ((0, 0, 0, 1) :: W.Word128) * (maxBound :: W.Word128) === (maxBound :: W.Word128) + + it "should implement shift" $ requireTest $ do + ((1, 1, 1, 1) :: W.Word128) `B.shift` (16 :: Int) === ((0x10000, 0x10000, 0x10000, 0x10000) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) `B.shift` (32 :: Int) === ((1, 1, 1, 0) :: W.Word128) + ((1, 1, 1, 0xffffffff) :: W.Word128) `B.shift` (32 :: Int) === ((1, 1, 0xffffffff, 0) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) `B.shiftR` (16 :: Int) === ((0, 0x10000, 0x10000, 0x10000) :: W.Word128) + ((1, 1, 1, 1) :: W.Word128) `B.shiftR` (32 :: Int) === ((0, 1, 1, 1) :: W.Word128) + ((1, 1, 0xffffffff, 1) :: W.Word128) `B.shiftR` (32 :: Int) === ((0, 1, 1, 0xffffffff) :: W.Word128) + (maxBound :: W.Word128) `B.shift` (1 :: Int) === ((0xffffffff, 0xffffffff, 0xffffffff, 0xfffffffe) :: W.Word128) + + it "should implement Bits" $ requireTest $ do + B.countLeadingZeros ((0, 0, 0, 0) :: W.Word128) === 128 + B.countLeadingZeros ((0, 0, 0, 1) :: W.Word128) === 127 + B.countLeadingZeros ((1, 1, 1, 1) :: W.Word128) === 31 + B.countTrailingZeros ((0, 0, 0, 1) :: W.Word128) === 0 + B.countTrailingZeros ((0, 0, 0, 0) :: W.Word128) === 128 + B.countTrailingZeros ((0, 0, 0x10, 0) :: W.Word128) === 36