text-postgresql-0.0.3.0: test/prop.hs

{-# 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