protocol-radius-test (empty) → 0.0.1.0
raw patch · 7 files changed
+386/−0 lines, 7 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, containers, protocol-radius, protocol-radius-test, quickcheck-simple, transformers
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- protocol-radius-test.cabal +56/−0
- src/Test/Data/Radius/Arbitraries.hs +142/−0
- src/Test/Data/Radius/Iso.hs +144/−0
- test-mains/iso.hs +7/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for protocol-radius-test++## 0.0.1.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ protocol-radius-test.cabal view
@@ -0,0 +1,56 @@+name: protocol-radius-test+version: 0.0.1.0+synopsis: testsuit of protocol-radius haskell package+description: This package provides+ testsuit of protocol-radius haskell package.+license: BSD3+license-file: LICENSE+author: Kei Hibino+maintainer: ex8k.hibino@gmail.com+-- copyright:+category: Testing+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+tested-with: 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+ , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3++library+ exposed-modules:+ Test.Data.Radius.Iso+ Test.Data.Radius.Arbitraries+ -- other-modules:+ other-extensions: FlexibleInstances+ build-depends: base <5+ , quickcheck-simple >=0.1+ , containers+ , transformers+ , bytestring+ , cereal+ , protocol-radius+ , QuickCheck+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++test-suite isomorphism+ build-depends: base <5+ , protocol-radius-test+ , quickcheck-simple+ type: exitcode-stdio-1.0+ main-is: iso.hs+ hs-source-dirs: test-mains+ ghc-options: -Wall++ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/khibino/haskell-protocol-radius-test++source-repository head+ type: mercurial+ location: https://bitbucket.org/khibino/haskell-protocol-radius-test
+ src/Test/Data/Radius/Arbitraries.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleInstances #-}++module Test.Data.Radius.Arbitraries (+ genPacket,+ ) where++import Test.QuickCheck (Arbitrary (..), Gen, oneof, 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 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 (..))+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+ [ Attribute' . Standard <$> arbitrary <*> genSizedString (255 - 1 - 1)+ , 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+ case untypeNumber n of+ Standard _ -> Attribute n <$> genAtText (255 - 1 - 1)+ Vendors _ -> Attribute n <$> genAtText (255 - 1 - 1 - 4 - 1 - 1)++instance TypedNumberSets v => Arbitrary (Attribute v AtString) where+ arbitrary = do+ n <- elements $ Set.toList attributeNumbersString+ case untypeNumber n of+ Standard _ -> Attribute n <$> genAtString (255 - 1 - 1)+ Vendors _ -> Attribute n <$> genAtString (255 - 1 - 1 - 4 - 1 - 1)++instance TypedNumberSets v => Arbitrary (Attribute v AtInteger) where+ arbitrary =+ Attribute+ <$> elements (Set.toList attributeNumbersInteger)+ <*> arbitrary++{-+-- attributeNumbersIpV4 is empty list+instance Arbitrary (Attribute AtIpV4) where+ arbitrary =+ Attribute+ <$> 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)."
+ src/Test/Data/Radius/Iso.hs view
@@ -0,0 +1,144 @@+module Test.Data.Radius.Iso (+ tests,++ isoAttribute',+ isoPacket,+ isoAttributeText,+ isoAttributeString,+ isoAttributeInteger,+ -- isoAttributeIpV4,+ ) where++import Test.Data.Radius.Arbitraries ()++import Test.QuickCheck.Simple (Test, qcTest)++import Control.Applicative ((<$>))+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Serialize.Get (Get, runGet)+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.Attribute (Attribute', Attribute, TypedNumberSets)+import qualified Data.Radius.StreamGet as Get+import Data.Radius.StreamPut (AttributePutM)+import qualified Data.Radius.StreamPut as Put+++isoCode :: Code -> Bool+isoCode c =+ runGet Get.code (runPut $ Put.code c)+ ==+ Right c++isoBin128 :: Bin128 -> Bool+isoBin128 b =+ runGet Get.bin128 (runPut $ Put.bin128 b)+ ==+ Right b++isoHeader :: Header -> Bool+isoHeader h =+ 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+isoAtText v =+ runGet (Get.atText $ BS.length bs) bs+ ==+ Right v+ where bs = runPut $ Put.atText v++isoAtString :: AtString -> Bool+isoAtString v =+ runGet (Get.atString $ BS.length bs) bs+ ==+ Right v+ where bs = runPut $ Put.atString v++isoAtInteger :: AtInteger -> Bool+isoAtInteger v =+ runGet Get.atInteger (runPut $ Put.atInteger v)+ ==+ Right v++isoAtIpV4 :: AtIpV4 -> Bool+isoAtIpV4 v =+ runGet Get.atIpV4 (runPut $ Put.atIpV4 v)+ ==+ Right v++putAttribute :: (v -> ByteString -> Put) -> AttributePutM v a -> Put+putAttribute vPut = mapM_ (Put.attribute' vPut) . Put.extractAttributes++isoAttributeText :: (Ord v, TypedNumberSets v)+ => Get (Attribute' v)+ -> (v -> ByteString -> Put)+ -> Attribute v AtText+ -> Bool+isoAttributeText vGet vPut at =+ ( (runMaybeT . Get.decodeAsText <$>) . runGet (Get.attribute' vGet) . runPut . putAttribute vPut $ Put.attribute at )+ ==+ Right (Right (Just at))++isoAttributeString :: (Ord v, TypedNumberSets v)+ => Get (Attribute' v)+ -> (v -> ByteString -> Put)+ -> Attribute v AtString+ -> Bool+isoAttributeString vGet vPut at =+ ( (runMaybeT . Get.decodeAsString <$>) . runGet (Get.attribute' vGet) . runPut . putAttribute vPut $ Put.attribute at )+ ==+ Right (Right (Just at))++isoAttributeInteger :: (Ord v, TypedNumberSets v)+ => Get (Attribute' v)+ -> (v -> ByteString -> Put)+ -> Attribute v AtInteger+ -> Bool+isoAttributeInteger vGet vPut at =+ ( (runMaybeT . Get.decodeAsInteger <$>) . runGet (Get.attribute' vGet) . runPut . putAttribute vPut $ 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))+ -}++tests :: [Test]+tests =+ [ qcTest "iso - code" isoCode+ , qcTest "iso - bin128" isoBin128+ , qcTest "iso - header" isoHeader++ , qcTest "iso - atText" isoAtText+ , qcTest "iso - atString" isoAtString+ , qcTest "iso - atInteger" isoAtInteger+ , qcTest "iso - atIpV4" isoAtIpV4+ ]
+ test-mains/iso.hs view
@@ -0,0 +1,7 @@++import Test.QuickCheck.Simple (defaultMain)++import Test.Data.Radius.Iso (tests)++main :: IO ()+main = defaultMain tests