diff --git a/src/Data/PostgreSQL/NetworkAddress.hs b/src/Data/PostgreSQL/NetworkAddress.hs --- a/src/Data/PostgreSQL/NetworkAddress.hs +++ b/src/Data/PostgreSQL/NetworkAddress.hs @@ -1,6 +1,6 @@ -- | -- Module : Data.PostgreSQL.NetworkAddress --- Copyright : 2015 Kei Hibino +-- Copyright : 2015-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -10,35 +10,40 @@ -- This module defines network-address types of PostgreSQL. -- http://www.postgresql.org/docs/current/static/datatype-net-types.html module Data.PostgreSQL.NetworkAddress - ( NetAddress (..) - , V4HostAddress (..), v4HostAddressOctets - , V6HostAddress (..), v6HostAddressLong, v6HostAddressWords - , v6HostAddress, v6HostAddressL, v6HostAddressR + ( -- * Definitions about inet and cidr types + Inet (..), Cidr (..), cidr4, cidr4', cidr6, cidr6', - , Inet (..), Cidr (..) + -- * Definitions about the address type which is the pair of host-address and mask + NetAddress (..), netAddress4, netAddress6, + + -- * Definitions about the host-address types + V4HostAddress (..), v4HostAddressOctets, + V6HostAddress (..), v6HostAddressLong, v6HostAddressWords, + v6HostAddress, v6HostAddressL, v6HostAddressR, ) where import Control.Applicative (pure) import Control.Monad (guard) -import Data.Word (Word8, Word16) +import Data.Word (Word8, Word16, Word32) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) --- | Host address type along with IPv4 address string. +-- | Host address type along with IPv4 address bytes with IPv4 string order. data V4HostAddress = V4HostAddress !Word8 !Word8 !Word8 !Word8 - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) v4HostAddressOctets :: V4HostAddress -> (Word8, Word8, Word8, Word8) v4HostAddressOctets (V4HostAddress a b c d) = (a, b, c, d) --- | Host address type along with IPv6 address string. +-- | Host address type along with IPv6 address words with IPv6 string order. -- Each 'Word16' value is host byte order. -- Host byte order is portable in programs on its own host. -- Network byte order is only needed, when communicating other hosts. data V6HostAddress = V6HostAddress !Word16 !Word16 !Word16 !Word16 !Word16 !Word16 !Word16 !Word16 - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) v6HostAddressLong :: Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 -> Word16 @@ -47,9 +52,9 @@ v6HostAddress :: [Word16] -> [Word16] -> Maybe V6HostAddress v6HostAddress ls rs = do - let v6length = 8 - guard . null . drop v6length $ ls ++ rs - [a, b, c, d, e, f, g, h] <- pure $ ls ++ replicate (v6length - length ls - length rs) 0 ++ rs + let zlength = 8 {- v6 length -} - length (ls ++ rs) + guard $ zlength >= 0 + [a, b, c, d, e, f, g, h] <- pure $ ls ++ replicate zlength 0 ++ rs pure $ v6HostAddressLong a b c d e f g h v6HostAddressR :: [Word16] -> Maybe V6HostAddress @@ -62,12 +67,99 @@ v6HostAddressWords (V6HostAddress a b c d e f g h) = (a, b, c, d, e, f, g, h) - +-- | IPv4 or IPv6 netword address corresponding /. +-- eg. '192.168.0.1/24' data NetAddress = NetAddress4 !V4HostAddress !Word8 | NetAddress6 !V6HostAddress !Word8 - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) -newtype Inet = Inet NetAddress deriving (Eq, Ord, Show) +vmask4 :: (Ord a, Integral a) => a -> Bool +vmask4 = (<= 32) -newtype Cidr = Cidr NetAddress deriving (Eq, Ord, Show) +-- | Make IPv4 NetAddress type consistent with IPv4 mask +netAddress4 :: V4HostAddress -- ^ IPv4 host-address + -> Word8 -- ^ IPv4 mask 0-32 + -> Maybe NetAddress -- ^ result NetAddress +netAddress4 a4 m + | vmask4 m = Just $ NetAddress4 a4 m + | otherwise = Nothing + +vmask6 :: (Ord a, Integral a) => a -> Bool +vmask6 = (<= 128) + +-- | Make IPv6 NetAddress type consistent with IPv6 mask +netAddress6 :: V6HostAddress -- ^ IPv6 host-address + -> Word8 -- ^ IPv6 mask 0-128 + -> Maybe NetAddress -- ^ result NetAddress +netAddress6 a6 m + | vmask6 m = Just $ NetAddress6 a6 m + | otherwise = Nothing + +-- | Corresponding to INET type of PostgreSQL +newtype Inet = Inet NetAddress deriving (Eq, Ord, Show, Read) + +-- | Corresponding to CIDR type of PostgreSQL +newtype Cidr = Cidr NetAddress deriving (Eq, Ord, Show, Read) + +maskCidr4 :: V4HostAddress -> Word8 -> (Word32, Word32) +maskCidr4 (V4HostAddress w0 w1 w2 w3) m = + (a4 .&. (1 `shiftL` mi - 1) `shiftL` (32 - mi), a4) + where + mi = fromIntegral m + a4 :: Word32 + a4 = foldr (.|.) 0 $ zipWith + (\w x -> fromIntegral w `shiftL` x) + [w3, w2, w1, w0] + [0,8 ..] + +-- | Same as cidr4 except for dropping host-address bits along with mask +cidr4' :: V4HostAddress -> Word8 -> Maybe Cidr +cidr4' ha0 m = do + guard $ vmask4 m + let (ra, _) = maskCidr4 ha0 m + ha = fromList4 $ map (byte . (ra `shiftR`)) [24,16,8,0] + return . Cidr $ NetAddress4 ha m + where + byte = fromIntegral . (.&. 0xff) + fromList4 ws = V4HostAddress w0 w1 w2 w3 + where [w0, w1, w2, w3] = ws + +-- | Make Cidr type of IPv4 from host-address bits consistent with mask +cidr4 :: V4HostAddress -> Word8 -> Maybe Cidr +cidr4 ha m = do + na <- netAddress4 ha m + let (ma, ra) = maskCidr4 ha m + guard $ ma == ra + return $ Cidr na + +maskCidr6 :: V6HostAddress -> Word8 -> (Integer, Integer) +maskCidr6 (V6HostAddress w0 w1 w2 w3 w4 w5 w6 w7) m = + (a6 .&. (1 `shiftL` mi - 1) `shiftL` (128 - mi), a6) + where + mi = fromIntegral m + a6 :: Integer + a6 = foldr (.|.) 0 $ zipWith + (\w x -> fromIntegral w `shiftL` x) + [w7, w6, w5, w4, w3, w2, w1, w0] + [0,16 ..] + +-- | Same as cidr6 except for dropping host-address bits along with mask +cidr6' :: V6HostAddress -> Word8 -> Maybe Cidr +cidr6' ha0 m = do + guard $ vmask6 m + let (ra, _) = maskCidr6 ha0 m + ha = fromList6 $ map (word . (ra `shiftR`)) [112, 96 .. 0] + return . Cidr $ NetAddress6 ha m + where + word = fromIntegral . (.&. 0xffff) + fromList6 ws = V6HostAddress w0 w1 w2 w3 w4 w5 w6 w7 + where [w0, w1, w2, w3, w4, w5, w6, w7] = ws + +-- | Make Cidr type of IPv6 from host-address bits consistent with mask +cidr6 :: V6HostAddress -> Word8 -> Maybe Cidr +cidr6 ha m = do + na <- netAddress6 ha m + let (ma, ra) = maskCidr6 ha m + guard $ ma == ra + return $ Cidr na diff --git a/test/ppIso.hs b/test/ppIso.hs deleted file mode 100644 --- a/test/ppIso.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -{--# LANGUAGE FlexibleInstances #--} - -import Test.QuickCheck - (Gen, Arbitrary (..), choose, oneof) -import Test.QuickCheck.Simple (defaultMain, Test, qcTest) - -import Control.Applicative ((<$>), (<*>)) -import Data.Word (Word8) - -import Data.PostgreSQL.NetworkAddress -import Database.PostgreSQL.Parser (Parser, evalParser) -import qualified Database.PostgreSQL.Parser as Parser -import Database.PostgreSQL.Printer (Printer, execPrinter) -import qualified Database.PostgreSQL.Printer as Printer - - -instance Arbitrary V4HostAddress where - arbitrary = - V4HostAddress - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary V6HostAddress where - arbitrary = - V6HostAddress - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - -mask4 :: Gen Word8 -mask4 = choose (0, 32) - -mask6 :: Gen Word8 -mask6 = choose (0, 128) - -instance Arbitrary NetAddress where - arbitrary = - oneof - [ NetAddress4 <$> arbitrary <*> mask4 - , NetAddress6 <$> arbitrary <*> mask6 ] - -isoProp :: Eq a => Printer a -> Parser a -> a -> Bool -isoProp pr ps a = - Right a == (evalParser ps $ execPrinter pr a) - -prop_v4HostAddressIso :: V4HostAddress -> Bool -prop_v4HostAddressIso = - isoProp Printer.v4HostAddress Parser.v4HostAddress - -prop_v6HostAddressIso :: V6HostAddress -> Bool -prop_v6HostAddressIso = - isoProp Printer.v6HostAddress Parser.v6HostAddress - -prop_netAddressIso :: NetAddress -> Bool -prop_netAddressIso = - isoProp Printer.netAddress Parser.netAddress - -tests :: [Test] -tests = - [ qcTest "v4 address iso - print parse" prop_v4HostAddressIso - , qcTest "v6 address iso - print parse" prop_v6HostAddressIso - , qcTest "network address iso - print parse" prop_netAddressIso - ] - -main :: IO () -main = defaultMain tests diff --git a/test/prop.hs b/test/prop.hs new file mode 100644 --- /dev/null +++ b/test/prop.hs @@ -0,0 +1,152 @@ +{-# OPTIONS -fno-warn-orphans #-} + +import Test.QuickCheck + (Gen, Arbitrary (..), choose, oneof) +import Test.QuickCheck.Simple (defaultMain, Test, qcTest) + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (replicateM) +import Data.Maybe (fromJust) +import Data.List (isPrefixOf, isSuffixOf) +import Data.Word (Word8, Word16) + +import Data.PostgreSQL.NetworkAddress +import Database.PostgreSQL.Parser (Parser, evalParser) +import qualified Database.PostgreSQL.Parser as Parser +import Database.PostgreSQL.Printer (Printer, execPrinter) +import qualified Database.PostgreSQL.Printer as Printer + + +instance Arbitrary V4HostAddress where + arbitrary = + V4HostAddress + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary V6HostAddress where + arbitrary = + V6HostAddress + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +mask4 :: Gen Word8 +mask4 = choose (0, 32) + +mask6 :: Gen Word8 +mask6 = choose (0, 128) + +newtype A6Input = + A6Input [Word16] + deriving (Eq, Show) + +instance Arbitrary A6Input where + arbitrary= A6Input <$> (choose (0, 8) >>= (`replicateM` arbitrary)) + +instance Arbitrary NetAddress where + arbitrary = + oneof + [ NetAddress4 <$> arbitrary <*> mask4 + , NetAddress6 <$> arbitrary <*> mask6 ] + +instance Arbitrary Cidr where + arbitrary = + oneof + [ fromJust <$> (cidr4' <$> arbitrary <*> mask4) + , fromJust <$> (cidr6' <$> arbitrary <*> mask6) ] + +isoProp :: Eq a => Printer a -> Parser a -> a -> Bool +isoProp pr ps a = + Right a == (evalParser ps $ execPrinter pr a) + +prop_v4HostAddressIso :: V4HostAddress -> Bool +prop_v4HostAddressIso = + isoProp Printer.v4HostAddress Parser.v4HostAddress + +prop_v6HostAddressIso :: V6HostAddress -> Bool +prop_v6HostAddressIso = + isoProp Printer.v6HostAddress Parser.v6HostAddress + +prop_v6HostAddressDcIsoL :: V6HostAddress -> Bool +prop_v6HostAddressDcIsoL a6 = + v6HostAddress [w0, w1, w2, w3, w4, w5, w6, w7] [] == Just a6 + where + (w0, w1, w2, w3, w4, w5, w6, w7) = v6HostAddressWords a6 + +prop_v6HostAddressDcIsoR :: V6HostAddress -> Bool +prop_v6HostAddressDcIsoR a6 = + v6HostAddress [] [w0, w1, w2, w3, w4, w5, w6, w7] == Just a6 + where + (w0, w1, w2, w3, w4, w5, w6, w7) = v6HostAddressWords a6 + +prop_v6HostAddressCons :: A6Input -> A6Input -> Bool +prop_v6HostAddressCons (A6Input il) (A6Input ir) = case v6HostAddress il ir of + Nothing -> length (il ++ ir) > 8 + Just (V6HostAddress w0 w1 w2 w3 w4 w5 w6 w7) + | let ws = [w0, w1, w2, w3, w4, w5, w6, w7] -> + length (il ++ ir) <= 8 && il `isPrefixOf` ws && ir `isSuffixOf` ws + +prop_netAddressPpIso :: NetAddress -> Bool +prop_netAddressPpIso = + isoProp Printer.netAddress Parser.netAddress + +prop_netAddressDcIso :: NetAddress -> Bool +prop_netAddressDcIso na = dc == Just na where + dc = case na of + NetAddress4 a4 m -> netAddress4 a4 m + NetAddress6 a6 m -> netAddress6 a6 m + +prop_netAddress4Cons :: V4HostAddress -> Word8 -> Bool +prop_netAddress4Cons a4 m = case netAddress4 a4 m of + Nothing -> m > 32 + Just (NetAddress4 a4' m') -> a4 == a4' && m == m' + Just (NetAddress6 {}) -> False + +prop_netAddress6Cons :: V6HostAddress -> Word8 -> Bool +prop_netAddress6Cons a6 m = case netAddress6 a6 m of + Nothing -> m > 128 + Just (NetAddress4 {}) -> False + Just (NetAddress6 a6' m') -> a6 == a6' && m == m' + +prop_cidrDcIso :: Cidr -> Bool +prop_cidrDcIso cidr@(Cidr na) = dc == Just cidr where + dc = case na of + NetAddress4 a4 m -> cidr4 a4 m + NetAddress6 a6 m -> cidr6 a6 m + +prop_cidr4Cons :: V4HostAddress -> Word8 -> Bool +prop_cidr4Cons a4 m = case cidr4 a4 m of + Nothing -> m > 32 || + case cidr4' a4 m of + Nothing -> False + Just (Cidr (NetAddress4 a4' m')) -> m' == m && a4' /= a4 + Just (Cidr (NetAddress6 {})) -> False + Just (Cidr (NetAddress4 a4' m')) -> m' == m && a4' == a4 + Just (Cidr (NetAddress6 {})) -> False + +prop_cidr6Cons :: V6HostAddress -> Word8 -> Bool +prop_cidr6Cons a6 m = case cidr6 a6 m of + Nothing -> m > 128 || + case cidr6' a6 m of + Nothing -> False + Just (Cidr (NetAddress4 {})) -> False + Just (Cidr (NetAddress6 a6' m')) -> m' == m && a6' /= a6 + Just (Cidr (NetAddress4 {})) -> False + Just (Cidr (NetAddress6 a6' m')) -> m' == m && a6' == a6 + +tests :: [Test] +tests = + [ qcTest "v4 address iso - print parse" prop_v4HostAddressIso + , qcTest "v6 address iso - print parse" prop_v6HostAddressIso + , qcTest "v6 address iso - destruct construct-left" prop_v6HostAddressDcIsoL + , qcTest "v6 address iso - destruct construct-right" prop_v6HostAddressDcIsoR + , qcTest "v6 address construction" prop_v6HostAddressCons + , qcTest "network address iso - print parse" prop_netAddressPpIso + , qcTest "network address iso - destruct construct" prop_netAddressDcIso + , qcTest "network address 4 construction" prop_netAddress4Cons + , qcTest "network address 6 construction" prop_netAddress6Cons + , qcTest "cidr iso - destruct construct" prop_cidrDcIso + , qcTest "cidr-4 construction" prop_cidr4Cons + , qcTest "cidr-6 construction" prop_cidr6Cons + ] + +main :: IO () +main = defaultMain tests diff --git a/text-postgresql.cabal b/text-postgresql.cabal --- a/text-postgresql.cabal +++ b/text-postgresql.cabal @@ -1,5 +1,5 @@ name: text-postgresql -version: 0.0.2.3 +version: 0.0.3.0 synopsis: Parser and Printer of PostgreSQL extended types description: This package involves parser and printer for text expressions of PostgreSQL extended types. @@ -9,12 +9,13 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com -copyright: Copyright (c) 2015-2017 Kei Hibino +copyright: Copyright (c) 2015-2018 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.2.1 +tested-with: GHC == 8.4.1, GHC == 8.4.2 + , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 @@ -37,13 +38,13 @@ hs-source-dirs: src default-language: Haskell2010 -test-suite pp +test-suite test-prop build-depends: base <5 , QuickCheck , quickcheck-simple , text-postgresql type: exitcode-stdio-1.0 - main-is: ppIso.hs + main-is: prop.hs hs-source-dirs: test ghc-options: -Wall