WriteSpec.hs

module Arbor.File.Format.Asif.WriteSpec where

import Arbor.File.Format.Asif.Data.Ip
import Arbor.File.Format.Asif.Format
import Arbor.File.Format.Asif.Segment
import Arbor.File.Format.Asif.Write
import Control.Lens
import Control.Monad.IO.Class                (liftIO)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
import Data.Int
import Data.List                             (elemIndex, nub)
import Data.Maybe                            (catMaybes, fromMaybe)
import Data.Semigroup                        ((<>))
import Data.Word
import HaskellWorks.Data.Network.Ip.Validity (Canonical)
import System.IO.Temp                        (openBinaryTempFile)

import HaskellWorks.Hspec.Hedgehog
import Hedgehog
import Test.Hspec

import qualified Data.Attoparsec.ByteString        as AP
import qualified Data.ByteString.Lazy              as LBS
import qualified Data.Text.Lazy                    as T
import qualified Data.Text.Lazy.Encoding           as T
import qualified Data.Thyme.Clock.POSIX            as TY
import qualified Data.Thyme.Time.Core              as TY
import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4
import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6
import qualified Hedgehog.Gen                      as G
import qualified Hedgehog.Range                    as R

import qualified System.IO as IO

import Debug.Trace


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

spec :: Spec
spec = describe "Arbor.File.Format.Asif.Write" $ do
  it "should write file and read it back again" $ require $ property $ do
    tplList <- forAll $ G.list (R.linear 0 50) genTriple

    let fld =  int64Segment                (\(a,_,_) -> a) "first"
            <> word16Segment               (\(_,a,_) -> a) "second"
            <> nullTerminatedStringSegment (\(_,_,a) -> T.toStrict a) "third"

    (_, f, h) <- openBinaryTempFile Nothing "wtite-asif-test.asif"

    _ <- writeAsif h "wxyz" Nothing fld tplList
    liftIO $ IO.hSeek h IO.AbsoluteSeek 0

    lbs <- liftIO $ LBS.hGetContents h

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, l1,l2,l3] <- forAll $ pure (segmentValues <$> segments)

    ((\(a,_,_) -> SInt64 a) <$> tplList) === l1
    ((\(_,a,_) -> SWord16 a) <$> tplList) === l2
    ((\(_,_,a) -> SString . T.encodeUtf8 $ a) <$> tplList) === l3

  it "should write several segments, then read them back in" $ require $ property $ do
    tplList <- forAll $ G.list (R.linear 0 50) genTriple

    let f1 = int64Segment                (\(a,_,_) -> a) "first"
    let f2 = word16Segment               (\(_,a,_) -> a) "second"
    let f3 = nullTerminatedStringSegment (\(_,_,a) -> T.toStrict a) "third"
    let fld = f1 <> f2 <> f3

    lbs <- asifContent "wxyz" Nothing fld tplList

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs

    [names, times, types, l1,l2,l3] <- forAll $ pure (segmentValues <$> segments)

    ((\(a,_,_) -> SInt64 a) <$> tplList) === l1
    ((\(_,a,_) -> SWord16 a) <$> tplList) === l2
    ((\(_,_,a) -> SString . T.encodeUtf8 $ a) <$> tplList) === l3

-----

  it "should write out and read back in a bool segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) G.bool

    lbs <- asifContent "wxyz" Nothing (boolSegment id "bool") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SBool <$> lst) === seg

  it "should write out and read back in a word8 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.word8 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (word8Segment id "word8") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SWord8 <$> lst) === seg

  it "should write out and read back in a word16 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.word16 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (word16Segment id "word16") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SWord16 <$> lst) === seg

  it "should write out and read back in a word32 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.word32 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (word32Segment id "word32") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SWord32 <$> lst) === seg

  it "should write out and read back in a word64 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.word64 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (word64Segment id "word64") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SWord64 <$> lst) === seg

-----

  it "should write out and read back in a int8 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.int8 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (int8Segment id "int8") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SInt8 <$> lst) === seg

  it "should write out and read back in a int16 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.int16 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (int16Segment id "int16") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SInt16 <$> lst) === seg

  it "should write out and read back in a int32 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.int32 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (int32Segment id "int32") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SInt32 <$> lst) === seg

  it "should write out and read back in a int64 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (G.int64 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (int64Segment id "int64") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SInt64 <$> lst) === seg

-----

  it "should write out and read back in a ipv4 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) genIpv4

    lbs <- asifContent "wxyz" Nothing (ipv4Segment id "ipv4") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SIpv4 <$> lst) === seg

  it "should write out and read back in a ipv6 segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) genIpv6

    lbs <- asifContent "wxyz" Nothing (ipv6Segment id "ipv6") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SIpv6 <$> lst) === seg

  it "should write out and read back in a ipv4 block segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) genIpv4Block

    lbs <- asifContent "wxyz" Nothing (ipv4BlockSegment id "ipv4Block") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SIpv4Block <$> lst) === seg

  it "should write out and read back in a ipv6 block segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) genIpv6Block

    lbs <- asifContent "wxyz" Nothing (ipv6BlockSegment id "ipv6Block") lst

    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SIpv6Block <$> lst) === seg

-----

  it "should write out and read back in a time segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) (TY.posixSecondsToUTCTime . TY.fromMicroseconds <$> G.int64 R.linearBounded)

    lbs <- asifContent "wxyz" Nothing (utcTimeMicrosSegment id "time") lst
    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (STime <$> lst) === seg

-----

  it "should write out and read back in a char segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) G.ascii

    lbs <- asifContent "wxyz" Nothing (asciiSegment id "char") lst
    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SChar <$> lst) === seg

  it "should write out and read back in a null-terminated string segment" $ require $ property $ do
    lst <- forAll $ G.list (R.linear 0 50) genNonNullText

    lbs <- asifContent "wxyz" Nothing (nullTerminatedStringSegment id "nullterminatedstring") (T.toStrict <$> lst)
    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    (SString . T.encodeUtf8 <$> lst) === seg

  it "should write out and read back in a text segment" $ require $ property $ do
    -- Explaination of this test:
    -- We can't deliniate 'breaks' in Text when we read it back in,
    -- so regardless of how many we write out, when we read it back we only
    -- get a single Text value.
    lst <- forAll $ G.list (R.linear 1 50) (G.text (R.linear 0 50) G.unicode)

    lbs <- asifContent "wxyz" Nothing (textSegment id "text") lst
    let Right segments = extractSegments (AP.string "seg:wxyz") lbs
    [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)

    [SText . T.encodeUtf8 . T.concat $ T.fromStrict <$> lst] === seg

  it "should write and read back a lookup segment" $ require $ property $ do
    let pairGen = (,) <$> genIpv4 <*> G.maybe (G.element ["US", "KZ", "AU"])
    pairs <- forAll $ G.list (R.linear 1 100) pairGen

    let countriesFold = nullTerminatedStringSegment id "countries"
    let countriesLookup = word16LookupSegment "ip-to-countries" snd countriesFold

    let resFold = ipv4Segment fst "ip" <> countriesLookup

    content <- asifContent "ipct" Nothing resFold pairs

    let Right segments = extractSegments (AP.string "seg:ipct") content

    [names, times, types, ips, lkp, dict] <- forAll $ pure (segmentValues <$> segments)

    let expectedVals    = pairs ^.. each . _2 . _Just & nub
    let expectedLkpVals = pairs ^.. each . _2 . to (\x -> x >>= flip elemIndex expectedVals) . to (fromMaybe maxBound)

    expectedDict <- forAll . pure $
      expectedVals <&> (SString . T.encodeUtf8 . T.fromStrict)

    expectedLkp <- forAll . pure $
      expectedLkpVals <&> (SWord16 . fromIntegral)

    dict === expectedDict
    lkp  === expectedLkp


genTriple :: MonadGen m => m (Int64, Word16, T.Text)
genTriple
  = (,,)
  <$> G.int64 R.linearBounded
  <*> G.word16 R.linearBounded
  <*> genNonNullText

genIpv4 :: MonadGen m => m IP4.IpAddress
genIpv4 = word32ToIpv4 <$> G.word32 R.linearBounded

genIpv6 :: MonadGen m => m IP6.IpAddress
genIpv6 = word32x4ToIpv6 <$> gen4
  where
    gen4 :: MonadGen m => m (Word32, Word32, Word32, Word32)
    gen4 =
      let g = G.word32 R.linearBounded
      in (,,,) <$> g <*> g <*> g <*> g

genIpv4Block :: MonadGen m => m (IP4.IpBlock Canonical)
genIpv4Block = do
  ip <- genIpv4
  mask <- IP4.IpNetMask <$> G.word8 (R.linear 0 32)
  pure . IP4.canonicaliseIpBlock $ IP4.IpBlock ip mask

genIpv6Block :: MonadGen m => m (IP6.IpBlock Canonical)
genIpv6Block = do
  ip <- genIpv6
  mask <- IP6.IpNetMask <$> G.word8 (R.linear 0 128)
  pure . IP6.canonicaliseIpBlock $ IP6.IpBlock ip mask

genNonNullText :: MonadGen m => m T.Text
genNonNullText =
  T.fromStrict <$> G.text (R.linear 0 32) (G.filter (/= toEnum 0) G.unicode)


instance MonadResource m => MonadResource (PropertyT m) where
  liftResourceT = lift . liftResourceT

-- I have no idea how this doesn't exist, but whatever. ¯\_(ツ)_/¯
instance MonadResource IO where
  liftResourceT = runResourceT