packages feed

text-postgresql 0.0.2.3 → 0.0.3.0

raw patch · 4 files changed

+268/−88 lines, 4 files

Files

src/Data/PostgreSQL/NetworkAddress.hs view
@@ -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 <host-addr>/<mask>.+--   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
− test/ppIso.hs 
@@ -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
+ test/prop.hs view
@@ -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
text-postgresql.cabal view
@@ -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