diff --git a/hw-ip.cabal b/hw-ip.cabal --- a/hw-ip.cabal +++ b/hw-ip.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: hw-ip -version: 0.3.0 +version: 0.4.0 synopsis: Library for manipulating IP addresses and CIDR blocks description: Please see README.md category: Network 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 @@ -16,25 +16,18 @@ fromIntegral d {-# INLINE fourOctetsToWord32 #-} -infixl 2 #<*># +infixl 4 #<*># (#<*>#) :: AP.Parser Word8 -> AP.Parser Word8 -> AP.Parser Word8 (#<*>#) pa pb = paste <$> pa <*> pb where paste a b = a * 10 + b octet :: AP.Parser Word8 -octet = ((d12 #<*># d5 ) #<*># d05) - <|> ((d12 #<*># d04) #<*># d09) - <|> ((d1 #<*># d09) #<*># d09) - <|> ( d19 #<*># d09) - <|> d09 - where d5 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (== '5') - d1 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (== '1') - d04 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= '0' && c <= '4') - d05 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= '0' && c <= '5') - d09 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= '0' && c <= '9') - d19 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= '1' && c <= '9') - d12 = fromIntegral . (+ (-48)) . ord <$> AP.satisfy (\c -> c >= '1' && c <= '2') +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 ipv4Address :: AP.Parser Word32 ipv4Address = fourOctetsToWord32 @@ -45,3 +38,22 @@ whitespace :: AP.Parser () whitespace = void $ many (AP.satisfy isSpace) + +ipv4NetMask :: AP.Parser Word8 +ipv4NetMask = d 3 #<*># ds 0 2 + <|> d 2 #<*># ds 0 9 + <|> d 1 #<*># ds 0 9 + <|> ds 0 9 + +d :: Int -> AP.Parser Word8 +d 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)) + +ipv4Block :: AP.Parser (Word32, Word8) +ipv4Block = do + addr <- ipv4Address + _ <- AP.char '/' + mask <- ipv4NetMask + return (addr, mask) diff --git a/src/HaskellWorks/Data/Network/Ip/Type.hs b/src/HaskellWorks/Data/Network/Ip/Type.hs --- a/src/HaskellWorks/Data/Network/Ip/Type.hs +++ b/src/HaskellWorks/Data/Network/Ip/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} module HaskellWorks.Data.Network.Ip.Type ( Ipv4Address(..) @@ -49,3 +50,12 @@ instance Show Ipv4Block where showsPrec _ (Ipv4Block b (Ipv4NetMask m)) = shows b . ('/':) . shows m + +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) -> [(Ipv4Block (Ipv4Address a) (Ipv4NetMask m), T.unpack i)] + AP.Partial _ -> [] + AP.Fail a b c -> [] + Nothing -> [] diff --git a/test/HaskellWorks/Data/Network/IpSpec.hs b/test/HaskellWorks/Data/Network/IpSpec.hs --- a/test/HaskellWorks/Data/Network/IpSpec.hs +++ b/test/HaskellWorks/Data/Network/IpSpec.hs @@ -3,25 +3,38 @@ module HaskellWorks.Data.Network.IpSpec (spec) where import HaskellWorks.Data.Network.Ip +import HaskellWorks.Data.Network.Ip.Internal import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec +import qualified Data.Attoparsec.Text as AP +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" $ require $ property $ 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" $ require $ property $ 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 + describe "Ipv4Block" $ do it "should implement show" $ require $ property $ do show (Ipv4Block (Ipv4Address 0x000000ff) (Ipv4NetMask 32)) === "0.0.0.255/32" @@ -42,11 +55,18 @@ 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" $ require $ property $ do + read "1.2.3.4/8" === Ipv4Block (Ipv4Address 0x01020304) (Ipv4NetMask 8) + read "1.2.3.4/0" === Ipv4Block (Ipv4Address 0x01020304) (Ipv4NetMask 0) + read "1.2.3.4/32" === Ipv4Block (Ipv4Address 0x01020304) (Ipv4NetMask 32) + it "should implement splitBlock" $ require $ property $ 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" $ require $ property $ do blockSize (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 32)) === 1 blockSize (Ipv4Block (Ipv4Address 0x00000000) (Ipv4NetMask 0)) === 0x100000000