LibProps.hs

{-# language OverloadedStrings #-}
module Props.LibProps (tests) where

-- bytestring
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS

-- case-insensitive
import qualified Data.CaseInsensitive as CI

-- hedgehog
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

-- http-client
import qualified Network.HTTP.Client as HC

-- tasty / tasty-hedgehog
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

-- text
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)

-- vty
import Graphics.Vty.Attributes (Style, reverseVideo)
import qualified Graphics.Vty.Attributes as VA
import Graphics.Vty.Image (charFill, imageHeight, imageWidth)

-- restman
import HTTP.Client (Header, UseDefaultHeaders(..))
import Lib
  ( cleanPayload
  , focusStyle
  , growWith
  , lbsToText
  , moveFocusNext
  , moveFocusPrev
  , splitExtraSpace
  )
import Types (AppR(..), AppS(..), RangeInAlign(..))
import UI (mkInitialState)

tests :: TestTree
tests = testGroup "Props.Lib"
  [ splitExtraSpaceProps
  , cleanPayloadProps
  , lbsToTextProps
  , focusStyleProps
  , focusCycleProps
  , growSpacesProps
  ]

-- ---------------------------------------------------------------------------
-- splitExtraSpace properties
--
-- splitExtraSpace :: RangeInAlign -> Int -> (Int, Int)
-- Precondition: second argument is positive (per documentation).
-- ---------------------------------------------------------------------------

genAlign :: Gen RangeInAlign
genAlign = Gen.element [Min, MidL, MidG, Max]

-- The two halves always sum to the input space.
prop_splitExtraSpace_sum :: Property
prop_splitExtraSpace_sum = property $ do
  align <- forAll genAlign
  n     <- forAll $ Gen.int (Range.linear 0 1000)
  let (l, r) = splitExtraSpace align n
  l + r === n

-- Min alignment: all space goes to the right (left is always 0).
prop_splitExtraSpace_min_left_zero :: Property
prop_splitExtraSpace_min_left_zero = property $ do
  n <- forAll $ Gen.int (Range.linear 0 1000)
  fst (splitExtraSpace Min n) === 0

-- Max alignment: all space goes to the left (right is always 0).
prop_splitExtraSpace_max_right_zero :: Property
prop_splitExtraSpace_max_right_zero = property $ do
  n <- forAll $ Gen.int (Range.linear 0 1000)
  snd (splitExtraSpace Max n) === 0

-- Both halves are non-negative for any alignment.
prop_splitExtraSpace_nonneg :: Property
prop_splitExtraSpace_nonneg = property $ do
  align <- forAll genAlign
  n     <- forAll $ Gen.int (Range.linear 0 1000)
  let (l, r) = splitExtraSpace align n
  assert (l >= 0)
  assert (r >= 0)

-- MidL and MidG are mirror images: swapping the pair converts one to the other.
prop_splitExtraSpace_midl_midg_swap :: Property
prop_splitExtraSpace_midl_midg_swap = property $ do
  n <- forAll $ Gen.int (Range.linear 0 1000)
  let (lL, rL) = splitExtraSpace MidL n
      (lG, rG) = splitExtraSpace MidG n
  lL === rG
  rL === lG

-- MidL gives the smaller (or equal) half to the left.
prop_splitExtraSpace_midl_left_le_right :: Property
prop_splitExtraSpace_midl_left_le_right = property $ do
  n <- forAll $ Gen.int (Range.linear 0 1000)
  let (l, r) = splitExtraSpace MidL n
  assert (l <= r)

-- MidG gives the larger (or equal) half to the left.
prop_splitExtraSpace_midg_left_ge_right :: Property
prop_splitExtraSpace_midg_left_ge_right = property $ do
  n <- forAll $ Gen.int (Range.linear 0 1000)
  let (l, r) = splitExtraSpace MidG n
  assert (l >= r)

splitExtraSpaceProps :: TestTree
splitExtraSpaceProps = testGroup "splitExtraSpace"
  [ testProperty "halves sum to n"               prop_splitExtraSpace_sum
  , testProperty "Min: left half is always 0"    prop_splitExtraSpace_min_left_zero
  , testProperty "Max: right half is always 0"   prop_splitExtraSpace_max_right_zero
  , testProperty "both halves are non-negative"  prop_splitExtraSpace_nonneg
  , testProperty "MidL and MidG are mirrors"     prop_splitExtraSpace_midl_midg_swap
  , testProperty "MidL: left <= right"           prop_splitExtraSpace_midl_left_le_right
  , testProperty "MidG: left >= right"           prop_splitExtraSpace_midg_left_ge_right
  ]

-- ---------------------------------------------------------------------------
-- cleanPayload properties
--
-- cleanPayload :: LBS.ByteString -> Text
-- Strips \ESC and \v; expands \t to four spaces.
-- ---------------------------------------------------------------------------

-- Generate arbitrary byte strings (arbitrary UTF-8 or binary).
genBytes :: Gen LBS.ByteString
genBytes = LBS.fromStrict <$> Gen.bytes (Range.linear 0 256)

-- ESC characters are always removed from the output.
prop_cleanPayload_no_esc :: Property
prop_cleanPayload_no_esc = property $ do
  bs <- forAll genBytes
  assert . not . Text.any (== '\ESC') $ cleanPayload bs

-- Vertical tab characters are always removed from the output.
prop_cleanPayload_no_vtab :: Property
prop_cleanPayload_no_vtab = property $ do
  bs <- forAll genBytes
  assert . not . Text.any (== '\v') $ cleanPayload bs

-- Tab characters are expanded and therefore absent from the output.
prop_cleanPayload_no_tab :: Property
prop_cleanPayload_no_tab = property $ do
  bs <- forAll genBytes
  assert . not . Text.any (== '\t') $ cleanPayload bs

-- Plain ASCII text that has no ESC/vtab/tab passes through unchanged.
prop_cleanPayload_plain_ascii_unchanged :: Property
prop_cleanPayload_plain_ascii_unchanged = property $ do
  t <- forAll $ Gen.text (Range.linear 0 100)
                  (Gen.filterT (`notElem` ['\ESC', '\v', '\t']) Gen.ascii)
  cleanPayload (LBS.fromStrict $ encodeUtf8 t) === t

cleanPayloadProps :: TestTree
cleanPayloadProps = testGroup "cleanPayload"
  [ testProperty "no ESC in output"            prop_cleanPayload_no_esc
  , testProperty "no vertical tab in output"   prop_cleanPayload_no_vtab
  , testProperty "no tab in output"            prop_cleanPayload_no_tab
  , testProperty "plain ASCII passes through"  prop_cleanPayload_plain_ascii_unchanged
  ]

-- ---------------------------------------------------------------------------
-- lbsToText properties
--
-- lbsToText :: LBS.ByteString -> Text
-- Decodes as UTF-8 with lenient error recovery.
-- ---------------------------------------------------------------------------

-- Encoding ASCII text and decoding it back yields the original.
prop_lbsToText_ascii_roundtrip :: Property
prop_lbsToText_ascii_roundtrip = property $ do
  t <- forAll $ Gen.text (Range.linear 0 200) Gen.ascii
  lbsToText (LBS.fromStrict $ encodeUtf8 t) === t

-- Decoding never throws — lenient mode replaces bad bytes with U+FFFD.
prop_lbsToText_never_throws :: Property
prop_lbsToText_never_throws = property $ do
  bs <- forAll genBytes
  _ <- evalNF (lbsToText bs)
  success

-- Valid Unicode text encoded as UTF-8 decodes back to itself.
prop_lbsToText_unicode_roundtrip :: Property
prop_lbsToText_unicode_roundtrip = property $ do
  t <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode
  lbsToText (LBS.fromStrict $ encodeUtf8 t) === t

lbsToTextProps :: TestTree
lbsToTextProps = testGroup "lbsToText"
  [ testProperty "ASCII encode/decode roundtrip" prop_lbsToText_ascii_roundtrip
  , testProperty "never throws on arbitrary bytes" prop_lbsToText_never_throws
  , testProperty "valid Unicode encode/decode roundtrip" prop_lbsToText_unicode_roundtrip
  ]

-- ---------------------------------------------------------------------------
-- focusStyle properties
--
-- focusStyle :: Style -> Style  (Style = Word)
-- Defined as `x `xor` reverseVideo`, so applying it twice is the identity.
-- ---------------------------------------------------------------------------

genStyle :: Gen Style
genStyle = Gen.integral (Range.linearBounded :: Range.Range Style)

-- Applying focusStyle twice is the identity (involution).
prop_focusStyle_involution :: Property
prop_focusStyle_involution = property $ do
  s <- forAll genStyle
  focusStyle (focusStyle s) === s

-- focusStyle on the zero style gives reverseVideo.
prop_focusStyle_zero_gives_reverseVideo :: Property
prop_focusStyle_zero_gives_reverseVideo = property $ do
  focusStyle 0 === reverseVideo

-- focusStyle on reverseVideo gives zero.
prop_focusStyle_reverseVideo_gives_zero :: Property
prop_focusStyle_reverseVideo_gives_zero = property $ do
  focusStyle reverseVideo === 0

focusStyleProps :: TestTree
focusStyleProps = testGroup "focusStyle"
  [ testProperty "applying twice is identity"       prop_focusStyle_involution
  , testProperty "0 maps to reverseVideo"           prop_focusStyle_zero_gives_reverseVideo
  , testProperty "reverseVideo maps to 0"           prop_focusStyle_reverseVideo_gives_zero
  ]

-- ---------------------------------------------------------------------------
-- moveFocusNext / moveFocusPrev cycle properties
--
-- With no custom headers the focus visits 5 positions in a fixed cycle:
--   UrlEditor -> DefaultHeadersToggle -> AddCustomHeader
--     -> ResponseBodyView -> MethodEditor -> UrlEditor
-- ---------------------------------------------------------------------------

-- A plain initial state (no custom headers, starts at UrlEditor).
baseState :: IO AppS
baseState = do
  mgr <- HC.newManager HC.defaultManagerSettings
  pure $ mkInitialState mgr "GET" ReplaceDefaultHeaders [] Nothing Nothing

-- Applying moveFocusNext 5 times returns focus to its starting position.
prop_moveFocusNext_cycle5 :: Property
prop_moveFocusNext_cycle5 = property $ do
  s0 <- evalIO baseState
  let sN = foldl' (flip ($)) s0 (replicate 5 moveFocusNext)
  focus sN === focus s0

-- Applying moveFocusPrev 5 times returns focus to its starting position.
prop_moveFocusPrev_cycle5 :: Property
prop_moveFocusPrev_cycle5 = property $ do
  s0 <- evalIO baseState
  let sN = foldl' (flip ($)) s0 (replicate 5 moveFocusPrev)
  focus sN === focus s0

-- moveFocusNext then moveFocusPrev is the identity on focus (no custom headers,
-- starting focus is not inside a custom-header row).
prop_moveFocusNext_then_prev_identity :: Property
prop_moveFocusNext_then_prev_identity = property $ do
  s0 <- evalIO baseState
  -- choose a simple starting focus (not ExistingCustomHeader or MethodSelector)
  startFocus <- forAll $ Gen.element
    [ MethodEditor, UrlEditor, DefaultHeadersToggle
    , AddCustomHeader, ResponseBodyView
    ]
  let s1 = s0 { focus = startFocus }
  focus (moveFocusPrev (moveFocusNext s1)) === startFocus

-- Applying moveFocusNext 8 times with one custom header returns focus to its
-- starting position (5 non-header stops + 3 per header = 8 total).
prop_moveFocusNext_cycle8_one_header :: Property
prop_moveFocusNext_cycle8_one_header = property $ do
  mgr <- evalIO $ HC.newManager HC.defaultManagerSettings
  let oneHeader :: [Header]
      oneHeader = [(CI.mk ("X-Test" :: BS.ByteString), "value")]
      s0 = mkInitialState mgr "GET" ReplaceDefaultHeaders oneHeader Nothing Nothing
      sN = foldl' (flip ($)) s0 (replicate 8 moveFocusNext)
  focus sN === focus s0

focusCycleProps :: TestTree
focusCycleProps = testGroup "focus cycle"
  [ testProperty "moveFocusNext: 5 steps is full cycle"              prop_moveFocusNext_cycle5
  , testProperty "moveFocusPrev: 5 steps is full cycle"              prop_moveFocusPrev_cycle5
  , testProperty "moveFocusNext then moveFocusPrev restores focus"   prop_moveFocusNext_then_prev_identity
  , testProperty "moveFocusNext: 8 steps with 1 header is full cycle" prop_moveFocusNext_cycle8_one_header
  ]

-- ---------------------------------------------------------------------------
-- growWith / growSpaces properties
--
-- growWith fillImg minW wa minH va img
-- Post-conditions: output width >= max(minW, imageWidth img)
--                  output height >= max(minH, imageHeight img)
-- ---------------------------------------------------------------------------

-- Output width is always at least the requested minimum.
prop_growSpaces_width_ge_min :: Property
prop_growSpaces_width_ge_min = property $ do
  minW <- forAll $ Gen.int (Range.linear 0 50)
  minH <- forAll $ Gen.int (Range.linear 1 50)
  srcW <- forAll $ Gen.int (Range.linear 1 50)
  srcH <- forAll $ Gen.int (Range.linear 1 50)
  align <- forAll genAlign
  let src = charFill VA.currentAttr ' ' srcW srcH
      img = growWith (charFill VA.currentAttr ' ') minW align minH align src
  assert (imageWidth img >= minW)

-- Output height is always at least the requested minimum.
prop_growSpaces_height_ge_min :: Property
prop_growSpaces_height_ge_min = property $ do
  minW <- forAll $ Gen.int (Range.linear 1 50)
  minH <- forAll $ Gen.int (Range.linear 0 50)
  srcW <- forAll $ Gen.int (Range.linear 1 50)
  srcH <- forAll $ Gen.int (Range.linear 1 50)
  align <- forAll genAlign
  let src = charFill VA.currentAttr ' ' srcW srcH
      img = growWith (charFill VA.currentAttr ' ') minW align minH align src
  assert (imageHeight img >= minH)

-- Output width is always at least the source image width.
prop_growSpaces_width_ge_src :: Property
prop_growSpaces_width_ge_src = property $ do
  minW <- forAll $ Gen.int (Range.linear 0 50)
  minH <- forAll $ Gen.int (Range.linear 1 50)
  srcW <- forAll $ Gen.int (Range.linear 1 50)
  srcH <- forAll $ Gen.int (Range.linear 1 50)
  align <- forAll genAlign
  let src = charFill VA.currentAttr ' ' srcW srcH
      img = growWith (charFill VA.currentAttr ' ') minW align minH align src
  assert (imageWidth img >= imageWidth src)

-- Output height is always at least the source image height.
prop_growSpaces_height_ge_src :: Property
prop_growSpaces_height_ge_src = property $ do
  minW <- forAll $ Gen.int (Range.linear 1 50)
  minH <- forAll $ Gen.int (Range.linear 0 50)
  srcW <- forAll $ Gen.int (Range.linear 1 50)
  srcH <- forAll $ Gen.int (Range.linear 1 50)
  align <- forAll genAlign
  let src = charFill VA.currentAttr ' ' srcW srcH
      img = growWith (charFill VA.currentAttr ' ') minW align minH align src
  assert (imageHeight img >= imageHeight src)

growSpacesProps :: TestTree
growSpacesProps = testGroup "growSpaces"
  [ testProperty "output width >= requested minimum"  prop_growSpaces_width_ge_min
  , testProperty "output height >= requested minimum" prop_growSpaces_height_ge_min
  , testProperty "output width >= source width"       prop_growSpaces_width_ge_src
  , testProperty "output height >= source height"     prop_growSpaces_height_ge_src
  ]