protocol-radius-test 0.0.1.0 → 0.1.0.0

raw patch · 10 files changed

+332/−119 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−2
• protocol-radius-test.cabal +10/−4
• src/Test/Data/Radius/Arbitraries.hs +6/−87
• src/Test/Data/Radius/ArbitrariesBase.hs +100/−0
• src/Test/Data/Radius/ArbitrariesNoVSA.hs +79/−0
• src/Test/Data/Radius/Iso.hs +2/−19
• src/Test/Data/Radius/IsoBase.hs +32/−0
• src/Test/Data/Radius/IsoNoVSA.hs +87/−0
• test-mains/iso.hs +0/−7
• test/iso.hs +10/−0

@@ -1,5 +1,9 @@ # Revision history for protocol-radius-test -## 0.0.1.0  -- YYYY-mm-dd+## 0.1.0.0  -- 2019-02-22 -* First version. Released on an unsuspecting world.+* Divide NoVSA modules.++## 0.0.1.0  -- 2017-12-17++* First version.

@@ -1,5 +1,5 @@ name:                protocol-radius-test-version:             0.0.1.0+version:             0.1.0.0 synopsis:            testsuit of protocol-radius haskell package description:         This package provides                      testsuit of protocol-radius haskell package.@@ -12,7 +12,9 @@ build-type:          Simple extra-source-files:  ChangeLog.md cabal-version:       >=1.10-tested-with:           GHC == 8.2.1, GHC == 8.2.2+tested-with:           GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3+                     , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3+                     , 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@@ -21,8 +23,12 @@ library   exposed-modules:                        Test.Data.Radius.Iso+                       Test.Data.Radius.IsoNoVSA                        Test.Data.Radius.Arbitraries-  -- other-modules:+                       Test.Data.Radius.ArbitrariesNoVSA+  other-modules:+                       Test.Data.Radius.IsoBase+                       Test.Data.Radius.ArbitrariesBase   other-extensions:    FlexibleInstances   build-depends:       base <5                      , quickcheck-simple >=0.1@@ -42,7 +48,7 @@                      , quickcheck-simple   type:              exitcode-stdio-1.0   main-is:           iso.hs-  hs-source-dirs:    test-mains+  hs-source-dirs:    test   ghc-options:       -Wall    default-language:  Haskell2010

@@ -5,51 +5,24 @@   genPacket,   ) where -import Test.QuickCheck (Arbitrary (..), Gen, oneof, elements, choose)+import Test.QuickCheck (Arbitrary (..), oneof, elements) -import Control.Applicative ((<$>), pure, (<*>))-import Control.Monad (replicateM)-import Data.String (IsString, fromString)-import qualified Data.ByteString as BS-import Data.Word (Word16)+import Test.Data.Radius.ArbitrariesBase+  (genPacket, genSizedString, genAtText, genAtString)++import Control.Applicative ((<$>), (<*>)) import qualified Data.Set as Set-import Data.Serialize.Put (Put, runPut)  import Data.Radius.Scalar-  (Bin128, word64Bin128, AtText (..), AtString (..), AtInteger (..), AtIpV4 (..))-import Data.Radius.Packet (codeFromWord, Code, Header(..), Packet (..))+  (AtText (..), AtString (..), AtInteger (..)) import Data.Radius.Attribute   (NumberAbstract (..), Attribute' (..), untypeNumber, Attribute (..),    TypedNumberSets (..), )-import qualified Data.Radius.Attribute as Attribute-import qualified Data.Radius.StreamPut as Put  -instance Arbitrary Code where-  arbitrary = codeFromWord <$> arbitrary--instance Arbitrary Bin128 where-  arbitrary = word64Bin128 <$> arbitrary <*> arbitrary--instance Arbitrary Attribute.Number where-  arbitrary =-    elements-    [ c-    | w <- [0  .. 255]-    , let c = Attribute.fromWord w-    , c /= Attribute.VendorSpecific-    ]- instance Arbitrary v => Arbitrary (NumberAbstract v) where   arbitrary = oneof [ Standard <$> arbitrary, Vendors <$> arbitrary ] -genSizedList :: Arbitrary a => Int -> Gen [a]-genSizedList n =-  elements [0..n] >>= (`replicateM` arbitrary)--genSizedString :: IsString a => Int -> Gen a-genSizedString n = fromString <$> genSizedList n- instance Arbitrary v => Arbitrary (Attribute' v) where   arbitrary =     oneof@@ -57,25 +30,7 @@     , Attribute' . Vendors  <$> arbitrary <*> genSizedString (255 - 1 - 1 - 4 - 1 - 1)     ] -genAtText :: Int -> Gen AtText-genAtText n = AtText <$> genSizedString (n  `quot` 4) -instance Arbitrary (AtText) where-  arbitrary = genAtText (255 - 1 - 1) {- USE CAREFULLY with vendor specific. -}--genAtString :: Int -> Gen AtString-genAtString n = AtString <$> genSizedString n--instance Arbitrary (AtString) where-  arbitrary = genAtString (255 - 1 - 1) {- USE CAREFULLY with vendor specific. -}--instance Arbitrary (AtInteger) where-  arbitrary = AtInteger <$> arbitrary--instance Arbitrary (AtIpV4) where-  arbitrary = AtIpV4 <$> arbitrary-- instance TypedNumberSets v => Arbitrary (Attribute v AtText) where   arbitrary = do     n  <-  elements $ Set.toList attributeNumbersText@@ -104,39 +59,3 @@     <$> elements (Set.toList attributeNumbersIpV4)     <*> arbitrary  -}---genHeader :: Word16 -> Gen Header-genHeader len =-  Header <$> arbitrary <*> arbitrary <*> pure len <*> arbitrary---- Random header, may be wrong length-instance Arbitrary Header where-  arbitrary = genHeader =<< arbitrary--pseudoHeader :: Header-pseudoHeader = Header (codeFromWord 0) 0 0 (word64Bin128 0 0)--genCountedPacket :: Arbitrary a-                 => Int-                 -> (a -> Put)-                 -> Gen (Packet [a], Int)-genCountedPacket ac encodeA = do-  attrs <- replicateM ac arbitrary-  let len = BS.length . runPut . Put.packet (mapM_ encodeA) $ Packet pseudoHeader attrs-  (,) <$> (Packet <$> (genHeader $ fromIntegral len) <*> pure attrs) <*> pure len--genPacket :: Arbitrary a-          => (a -> Put)-          -> Gen (Packet [a])-genPacket encodeA = do-  ac <- choose (0, 31)-  (p, len) <- genCountedPacket ac encodeA-  if len <= 4096-    then pure p-    else do-    ac <- choose (0, 15)-    (p, len) <- genCountedPacket ac encodeA-    if len <= 4096-      then pure p-      else fail "genPacket: this should not happen broken size property (header-size + 256 * 15 < 4096)."

@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}++module Test.Data.Radius.ArbitrariesBase (+  genPacket,++  genSizedString,+  genAtText, genAtString,+  ) where++import Test.QuickCheck (Arbitrary (..), Gen, elements, choose)++import Control.Applicative ((<$>), pure, (<*>))+import Control.Monad (replicateM)+import Data.String (IsString, fromString)+import qualified Data.ByteString as BS+import Data.Word (Word16)+import Data.Serialize.Put (Put, runPut)++import Data.Radius.Scalar+  (Bin128, word64Bin128, AtText (..), AtString (..), AtInteger (..), AtIpV4 (..))+import Data.Radius.Packet (codeFromWord, Code, Header(..), Packet (..))+import qualified Data.Radius.Attribute as Attribute+import qualified Data.Radius.StreamPut as Put+++instance Arbitrary Code where+  arbitrary = codeFromWord <$> arbitrary++instance Arbitrary Bin128 where+  arbitrary = word64Bin128 <$> arbitrary <*> arbitrary++instance Arbitrary Attribute.Number where+  arbitrary =+    elements+    [ c+    | w <- [0  .. 255]+    , let c = Attribute.fromWord w+    , c /= Attribute.VendorSpecific+    ]++genSizedList :: Arbitrary a => Int -> Gen [a]+genSizedList n =+  elements [0..n] >>= (`replicateM` arbitrary)++genSizedString :: IsString a => Int -> Gen a+genSizedString n = fromString <$> genSizedList n++genAtText :: Int -> Gen AtText+genAtText n = AtText <$> genSizedString (n  `quot` 4)++instance Arbitrary AtText where+  arbitrary = genAtText (255 - 1 - 1) {- USE CAREFULLY with vendor specific. -}++genAtString :: Int -> Gen AtString+genAtString n = AtString <$> genSizedString n++instance Arbitrary AtString where+  arbitrary = genAtString (255 - 1 - 1) {- USE CAREFULLY with vendor specific. -}++instance Arbitrary AtInteger where+  arbitrary = AtInteger <$> arbitrary++instance Arbitrary AtIpV4 where+  arbitrary = AtIpV4 <$> arbitrary+++genHeader :: Word16 -> Gen Header+genHeader len =+  Header <$> arbitrary <*> arbitrary <*> pure len <*> arbitrary++-- Random header, may be wrong length+instance Arbitrary Header where+  arbitrary = genHeader =<< arbitrary++pseudoHeader :: Header+pseudoHeader = Header (codeFromWord 0) 0 0 (word64Bin128 0 0)++genCountedPacket :: Arbitrary a+                 => Int+                 -> (a -> Put)+                 -> Gen (Packet [a], Int)+genCountedPacket ac encodeA = do+  attrs <- replicateM ac arbitrary+  let len = BS.length . runPut . Put.packet (mapM_ encodeA) $ Packet pseudoHeader attrs+  (,) <$> (Packet <$> (genHeader $ fromIntegral len) <*> pure attrs) <*> pure len++genPacket :: Arbitrary a+          => (a -> Put)+          -> Gen (Packet [a])+genPacket encodeA = do+  ac <- choose (0, 31)+  (p, len) <- genCountedPacket ac encodeA+  if len <= 4096+    then pure p+    else do+    ac <- choose (0, 15)+    (p, len) <- genCountedPacket ac encodeA+    if len <= 4096+      then pure p+      else fail "genPacket: this should not happen broken size property (header-size + 256 * 15 < 4096)."

@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleInstances #-}++module Test.Data.Radius.ArbitrariesNoVSA (+  EmptyVSA (),+  ) where++import Test.QuickCheck (Arbitrary (..), oneof, elements)++import Test.Data.Radius.ArbitrariesBase+  (genSizedString, genAtText, genAtString, genPacket)++import Control.Applicative ((<$>), pure, (<*>))+import qualified Data.Set as Set++import Data.Radius.Scalar+  (AtText (..), AtString (..), AtInteger (..))+import Data.Radius.Packet (Packet)+import Data.Radius.Attribute+  (NumberAbstract (..), Attribute' (..), Attribute (..), TypedNumberSets (..),+   numbersText, numbersString, numbersInteger)+import qualified Data.Radius.StreamPut as Put+++data EmptyVSA++instance Eq EmptyVSA where+  _ == _  =  True++instance Ord EmptyVSA where+  _ `compare` _  =  EQ++instance Show EmptyVSA where+  show _  =  "<EmptyVSA>"+++instance TypedNumberSets EmptyVSA where+  attributeNumbersText     = numbersText+  attributeNumbersString   = numbersString+  attributeNumbersInteger  = numbersInteger+  attributeNumbersIpV4     = Set.empty+++instance Arbitrary (NumberAbstract EmptyVSA) where+  arbitrary = oneof [ Standard <$> arbitrary ]++instance Arbitrary (Attribute' EmptyVSA) where+  arbitrary =+    Attribute' . Standard <$> arbitrary <*> genSizedString (255 - 1 - 1)+++instance Arbitrary (Attribute EmptyVSA AtText) where+  arbitrary =+    Attribute+    <$> elements (Set.toList numbersText)+    <*> genAtText (255 - 1 - 1)++instance Arbitrary (Attribute EmptyVSA AtString) where+  arbitrary =+    Attribute+    <$> elements (Set.toList numbersString)+    <*> genAtString (255 - 1 - 1)++instance Arbitrary (Attribute EmptyVSA AtInteger) where+  arbitrary =+    Attribute+    <$> elements (Set.toList numbersInteger)+    <*> arbitrary++{-+-- attributeNumbersIpV4 is empty list+instance Arbitrary (Attribute AtIpV4) where+  arbitrary =+    Attribute+    <$> elements (Set.toList attributeNumbersIpV4)+    <*> arbitrary+ -}++instance Arbitrary (Packet [Attribute' EmptyVSA]) where+  arbitrary = genPacket $ Put.attribute' $ \_ _ -> pure ()

@@ -10,6 +10,7 @@   ) where  import Test.Data.Radius.Arbitraries ()+import Test.Data.Radius.IsoBase (isoAttribute', isoPacket)  import Test.QuickCheck.Simple (Test, qcTest) @@ -21,7 +22,7 @@ import Data.Serialize.Put (Put, runPut)  import Data.Radius.Scalar (Bin128, AtText, AtString, AtInteger, AtIpV4)-import Data.Radius.Packet (Code, Header, Packet)+import Data.Radius.Packet (Code, Header) import Data.Radius.Attribute (Attribute', Attribute, TypedNumberSets) import qualified Data.Radius.StreamGet as Get import Data.Radius.StreamPut (AttributePutM)@@ -45,24 +46,6 @@   runGet Get.header (runPut $ Put.header h)   ==   Right h--isoAttribute' :: Eq a-              => Get (Attribute' a)-              -> (a -> ByteString -> Put)-              -> Attribute' a -> Bool-isoAttribute' vGet vPut a =-  runGet (Get.attribute' vGet) (runPut $ Put.attribute' vPut a)-  ==-  Right a--isoPacket :: Eq a-          => Get (Attribute' a)-          -> (a -> ByteString -> Put)-          -> Packet [Attribute' a] -> Bool-isoPacket vGet vPut p =-  runGet (Get.upacket vGet) (runPut $ Put.upacket vPut p)-  ==-  Right p   isoAtText :: AtText -> Bool

@@ -0,0 +1,32 @@+module Test.Data.Radius.IsoBase (+  isoAttribute',+  isoPacket,+  ) where++import Data.ByteString (ByteString)+import Data.Serialize.Get (Get, runGet)+import Data.Serialize.Put (Put, runPut)++import Data.Radius.Packet (Packet)+import Data.Radius.Attribute (Attribute')+import qualified Data.Radius.StreamGet as Get+import qualified Data.Radius.StreamPut as Put+++isoAttribute' :: Eq a+              => Get (Attribute' a)+              -> (a -> ByteString -> Put)+              -> Attribute' a -> Bool+isoAttribute' vGet vPut a =+  runGet (Get.attribute' vGet) (runPut $ Put.attribute' vPut a)+  ==+  Right a++isoPacket :: Eq a+          => Get (Attribute' a)+          -> (a -> ByteString -> Put)+          -> Packet [Attribute' a] -> Bool+isoPacket vGet vPut p =+  runGet (Get.upacket vGet) (runPut $ Put.upacket vPut p)+  ==+  Right p

@@ -0,0 +1,87 @@+module Test.Data.Radius.IsoNoVSA (+  tests,++  -- isoAttribute',+  -- isoPacket,+  -- isoAttributeText,+  -- isoAttributeString,+  -- isoAttributeInteger,+  -- isoAttributeIpV4,+  ) where++import Test.Data.Radius.ArbitrariesNoVSA (EmptyVSA)+import qualified Test.Data.Radius.IsoBase as Base+-- (isoAttribute', isoPacket)++import Test.QuickCheck.Simple (Test, qcTest)++import Control.Applicative ((<$>), pure)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.ByteString (ByteString)+import Data.Serialize.Get (Get, runGet)+import Data.Serialize.Put (Put, runPut)++import Data.Radius.Scalar (AtText, AtString)+import Data.Radius.Packet (Packet)+import Data.Radius.Attribute (Attribute', Attribute)+import qualified Data.Radius.StreamGet as Get+import Data.Radius.StreamPut (AttributePutM)+import qualified Data.Radius.StreamPut as Put+++getEmpty :: Get (Attribute' EmptyVSA)+getEmpty = fail "Vendor Specific Result type is bottom."++putEmpty ::  EmptyVSA -> ByteString -> Put+putEmpty _ _ = pure ()+++putAttribute :: AttributePutM EmptyVSA a -> Put+putAttribute = mapM_ (Put.attribute' putEmpty) . Put.extractAttributes++isoAttributeText :: Attribute EmptyVSA AtText+                 -> Bool+isoAttributeText at =+  ( (runMaybeT . Get.decodeAsText <$>) . runGet (Get.attribute' getEmpty) . runPut . putAttribute $ Put.attribute at )+  ==+  Right (Right (Just at))++isoAttributeString :: Attribute EmptyVSA AtString+                   -> Bool+isoAttributeString at =+  ( (runMaybeT . Get.decodeAsString <$>) . runGet (Get.attribute' getEmpty) . runPut . putAttribute $ Put.attribute at )+  ==+  Right (Right (Just at))++{-+isoAttributeInteger :: Attribute EmptyVSA AtInteger+                    -> Bool+isoAttributeInteger at =+  ( (runMaybeT . Get.decodeAsInteger <$>) . runGet (Get.attribute' getEmpty) . runPut . putAttribute $ Put.attribute at )+  ==+  Right (Right (Just at))+ -}++{-+isoAttributeIpV4 vGet vPut at =+  ( (runMaybeT . Get.decodeAsIpV4 <$>) . runGet (Get.attribute' vGet) . runPut . putAttribute vPut $ Put.attribute at )+  ==+  Right (Right (Just at))+ -}++isoAttribute' :: Attribute' EmptyVSA -> Bool+isoAttribute' = Base.isoAttribute' getEmpty putEmpty++isoPacket :: Packet [Attribute' EmptyVSA] -> Bool+isoPacket = Base.isoPacket getEmpty putEmpty++tests :: [Test]+tests =+  [ qcTest "iso - atText"             isoAttributeText+  , qcTest "iso - atString"           isoAttributeString+  --- , qcTest "iso - atInteger"          isoAttributeInteger+  --- , qcTest "iso - atIpV4"             isoAtIpV4++  , qcTest "iso - attribute'"         isoAttribute'+  , qcTest "iso - packet"             isoPacket+  ]

@@ -1,7 +0,0 @@--import Test.QuickCheck.Simple (defaultMain)--import Test.Data.Radius.Iso (tests)--main :: IO ()-main = defaultMain tests

@@ -0,0 +1,10 @@++import Test.QuickCheck.Simple (defaultMain)++import qualified Test.Data.Radius.Iso as V+import qualified Test.Data.Radius.IsoNoVSA as N++main :: IO ()+main = do+  defaultMain V.tests+  defaultMain N.tests