SegmentValueSpec.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Arbor.File.Format.Asif.Format.SegmentValueSpec
  ( spec
  ) where

import Arbor.File.Format.Asif.Data.Ip
import Arbor.File.Format.Asif.Format   as F
import Arbor.File.Format.Asif.Type
import Arbor.File.Format.Asif.Whatever
import Arbor.TestUtils
import Control.Lens
import Data.Semigroup                  ((<>))
import Data.Thyme.Time.Core
import HaskellWorks.Hspec.Hedgehog
import Hedgehog
import Test.Hspec

import qualified Data.ByteString.Builder    as BB
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.ByteString.Lazy.Char8 as LC8
import qualified Hedgehog.Gen               as Gen
import qualified Hedgehog.Range             as Range

{-# ANN module ("HLint: ignore Redundant do"  :: String) #-}

spec :: Spec
spec = describe "Arbor.File.Format.Asif.Format.RawValueSpec" $ do
  it "should parse strings" $ require $ property $ do
    bs <- forAll $ Gen.list (Range.linear 0 20) (genLazyBS (Range.linear 0 512) Gen.alphaNum)
    let body = mconcat $ (<> "\0") <$> bs
    let seg = segment body $ metaFormat (Known F.StringZ)
    segmentValues seg === fmap SString bs

  it "should parse chars" $ require $ property $ do
    bs <- forAll $ genLazyBS (Range.linear 0 512) Gen.latin1
    let expected = LC8.unpack bs <&> SChar
    let seg = segment bs $ metaFormat (Known F.Char)
    segmentValues seg === expected

  it "should parse time (micros)" $ require $ property $ do
    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 maxBound))
    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString
    let times = ts ^.. each . from microseconds . to posixSecondsToUTCTime
    let seg = segment body $ metaFormat (Known F.TimeMicros64LE)
    segmentValues seg === fmap STime times

  it "should parse time (millis)" $ require $ property $ do
    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 maxBound) <&> (`div` 1000))
    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString
    let times = ts ^.. each . to (*1000) . from microseconds . to posixSecondsToUTCTime
    let seg = segment body $ metaFormat (Known F.TimeMillis64LE)
    segmentValues seg === fmap STime times

  it "should parse int64" $ require $ property $ do
    testMany F.Int64LE SInt64 BB.int64LE (Gen.int64 (Range.linear 0 maxBound))

  it "should parse int32" $ require $ property $ do
    testMany F.Int32LE SInt32 BB.int32LE (Gen.int32 (Range.linear 0 maxBound))

  it "should parse int16" $ require $ property $ do
    testMany F.Int16LE SInt16 BB.int16LE (Gen.int16 (Range.linear 0 maxBound))

  it "should parse int8" $ require $ property $ do
    testMany F.Int8 SInt8 BB.int8 (Gen.int8 (Range.linear 0 maxBound))

  it "should parse word64" $ require $ property $ do
    testMany F.Word64LE SWord64 BB.word64LE (Gen.word64 (Range.linear 0 maxBound))

  it "should parse word32" $ require $ property $ do
    testMany F.Word32LE SWord32 BB.word32LE (Gen.word32 (Range.linear 0 maxBound))

  it "should parse word16" $ require $ property $ do
    testMany F.Word16LE SWord16 BB.word16LE (Gen.word16 (Range.linear 0 maxBound))

  it "should parse word8" $ require $ property $ do
    testMany F.Word8 SWord8 BB.word8 (Gen.word8 (Range.linear 0 maxBound))

  it "should parse BitString" $ require $ property $
    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict
    in testOne F.BitString SBitString BB.lazyByteString gen

  it "should parse Binary" $ require $ property $
    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict
    in testOne F.Binary SBinary BB.lazyByteString gen

  it "should parse Bitmap" $ require $ property $
    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict
    in testOne F.Bitmap SBitmap BB.lazyByteString gen

  it "should parse repeated BitString" $ require $ property $ do
    n <- forAll $ Gen.int (Range.linear 1 32)
    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.bytes (Range.singleton n) <&> LBS.fromStrict)
    let seg = segment (mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.BitString))
    segmentValues seg === fmap SBitString vs

  it  "should parse repeated chars" $ require $ property $ do
    n <- forAll $ Gen.int (Range.linear 1 32)
    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.string (Range.singleton n) Gen.alphaNum)
    let seg = segment (LC8.pack $ mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.Char))
    segmentValues seg === fmap (SList . fmap SChar) vs

  it "should parse repeated ips" $ require $ property $ do
    n <- forAll $ Gen.int (Range.linear 1 32)
    k <- forAll $ Gen.int (Range.linear 0 20)
    vs <- forAll $ Gen.list (Range.singleton (n*k)) (Gen.word32 Range.linearBounded)
    let body = vs <&> BB.word32LE & mconcat & BB.toLazyByteString
    let seg = segment body $ metaFormat (Known (Repeat (fromIntegral n) F.Ipv4))
    let expected = vs <&> (SIpv4 . word32ToIpv4) & chunksOf n <&> SList
    segmentValues seg === expected

genLazyBS :: MonadGen m => Range Int -> m Char -> m LBS.ByteString
genLazyBS rng gen = Gen.utf8 rng gen <&> LBS.fromStrict

testOne :: (Monad m, Show a)
        => Format
        -> (a -> SegmentValue)
        -> (a -> BB.Builder)
        -> Gen a
        -> PropertyT m ()
testOne fmt wrap put gen = do
  v <- forAll gen
  let body = put v & BB.toLazyByteString
  let seg = segment body $ metaFormat (Known fmt)
  segmentValues seg === [wrap v]

testMany :: (Monad m, Show a)
          => Format
          -> (a -> SegmentValue)
          -> (a -> BB.Builder)
          -> Gen a
          -> PropertyT m ()
testMany fmt wrap put gen = do
  vs <- forAll $ Gen.list (Range.linear 0 20) gen
  let body = vs <&> put & mconcat & BB.toLazyByteString
  let seg = segment body $ metaFormat (Known fmt)
  segmentValues seg === fmap wrap vs