IsoNoVSA.hs

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
  ]