module JSONParsingTest where
import Data.Aeson (Result (Success), ToJSON (toJSON), Value (..), decode, encode, fromJSON)
import Data.Aeson.KeyMap qualified as KM
import Data.Bits (FiniteBits)
import Data.Map.Strict qualified as M
import Data.Maybe (isNothing)
import Data.Text (Text, unpack)
import Data.Text qualified as T
import GHC.Plugins (HasCallStack)
import Test.Falsify.Generator as G
( Gen,
bool,
frequency,
inRange,
list,
)
import Test.Falsify.Predicate (dot, expect, fn, (.$))
import Test.Falsify.Range as R (between, enum)
import Test.Tasty (TestTree)
import Test.Tasty.Falsify
( ExpectFailure (DontExpectFailure),
Property,
TestOptions (..),
Verbose (Verbose),
assert,
gen,
info,
testPropertyWith,
)
import Test.Tasty.HUnit (Assertion, (@=?))
import Text.Show.Pretty (ppShow)
import WebDriverPreCore.HTTP.Protocol
( Capabilities (..),
DeviceMetrics (..),
LogLevel (..),
LogSettings (..),
MobileEmulation (..),
PerfLoggingPrefs (..),
Proxy (..),
SessionResponse (..),
SocksProxy (..),
Timeouts (..),
VendorSpecific (..)
)
import AesonUtils (jsonToText)
import Prelude hiding (log)
-- todo: ON SPLIT - moove to extras library
(===) ::
(Eq a, Show a, HasCallStack) =>
-- | The actual value
a ->
-- | The expected value
a ->
Assertion
(===) = (@=?)
genMaybe :: G.Gen a -> G.Gen (Maybe a)
genMaybe gen' =
G.frequency
[ (1, pure Nothing),
(3, Just <$> gen')
]
genOneOf :: forall a. (Enum a, Bounded a) => G.Gen a
genOneOf = G.inRange $ R.enum (minBound @a, maxBound @a)
genMEnum :: forall a. (Enum a, Bounded a) => G.Gen (Maybe a)
genMEnum = genMaybe $ genOneOf @a
genTextValueMap :: G.Gen (M.Map Text Value)
genTextValueMap =
M.fromList
<$> G.list
(R.between (0, 4))
((,) <$> genText <*> genValue)
where
genValue :: G.Gen Value
genValue =
G.frequency
[ (1, jv False),
(1, jv ""),
(1, jv 0),
(1, jv 1),
(1, jv 2),
(1, jv 3),
(1, jv 4),
(1, jv 5),
(1, jv 6),
(1, jv 7),
(1, jv 8),
(1, jv 9)
]
where
jv :: ToJSON a => a -> G.Gen Value
jv = pure . toJSON
genDeviseMetrics :: Gen DeviceMetrics
genDeviseMetrics = do
width <- genInt 0 10000
height <- genInt 0 10000
pixelRatio <- genDouble 0.0 10000.0
touch <- genBool
pure $ MkDeviceMetrics {..}
genMobileEmulation :: Gen MobileEmulation
genMobileEmulation = MkMobileEmulation <$> genMaybeText <*> genMaybe genDeviseMetrics <*> genMaybeText
genPerfLoggingPrefs :: G.Gen PerfLoggingPrefs
genPerfLoggingPrefs = do
enableNetwork <- genMaybeBool
enablePage <- genMaybeBool
enableTimeline <- genMaybeBool
traceCategories <- genMaybeText
bufferUsageReportingInterval <- genMaybeInt
pure $ MkPerfLoggingPrefs {..}
genVendorSpecific :: G.Gen VendorSpecific
genVendorSpecific =
G.frequency
[ ( 1,
-- edge and chrome options are the same at this stage
ChromeOptions
<$> genMaybeTextList
<*> genMaybeText
<*> genMaybeTextList
<*> genMaybe genTextValueMap
<*> genMaybe genMobileEmulation
<*> genMaybe genTextValueMap
<*> genMaybeBool
<*> genMaybe genText
<*> genMaybeTextList
<*> genMaybe genFilePath
<*> genMaybe genPerfLoggingPrefs
<*> genMaybeTextList
),
( 1,
EdgeOptions
<$> genMaybeTextList
<*> genMaybeText
<*> genMaybeTextList
<*> genMaybe genTextValueMap
<*> genMaybe genMobileEmulation
<*> genMaybe genTextValueMap
<*> genMaybeBool
<*> genMaybe genText
<*> genMaybeTextList
<*> genMaybe genFilePath
<*> genMaybe genPerfLoggingPrefs
<*> genMaybeTextList
),
(1, FirefoxOptions <$> genMaybeTextList <*> genMaybeText <*> genMaybeText <*> genMaybe genLogSettings),
(1, SafariOptions <$> genMaybeBool <*> genMaybeBool)
]
genLogLevel :: Gen LogLevel
genLogLevel =
G.frequency
[ (1, pure Trace),
(1, pure Debug),
(1, pure Info),
(1, pure Warning),
(1, pure Error),
(1, pure Fatal),
(1, pure Off)
]
genLogSettings :: G.Gen LogSettings
genLogSettings = do
level <- genLogLevel
pure $ MkLogSettings level
genBool :: G.Gen Bool
genBool = bool False
genMaybeBool :: G.Gen (Maybe Bool)
genMaybeBool = genMaybe genBool
genMaybeTimeout :: G.Gen (Maybe Int)
genMaybeTimeout = genMaybeInt
genMaybeInt :: G.Gen (Maybe Int)
genMaybeInt = genMaybe $ genInt 0 10000
genTimeouts :: G.Gen Timeouts
genTimeouts =
MkTimeouts
<$> genMaybeTimeout
<*> genMaybeTimeout
<*> genMaybeTimeout
genText :: G.Gen Text
genText =
G.frequency
[ (1, pure ""),
(1, pure "Awd34rtf"),
(1, pure "f"),
(1, pure "sfdsds"),
(1, pure "5"),
(1, pure "ttttttttttttt"),
(1, pure "a"),
(1, pure "zzzzz"),
(1, pure "rr"),
(1, pure "aa"),
(1, pure "pppp")
]
genFilePath :: G.Gen FilePath
genFilePath =
G.frequency
[ (1, pure "C:\\Program Files\\Google\\Chrome\\Application\\chrome.exe"),
(1, pure "C:\\Program Files\\Mozilla Firefox\\firefox.exe"),
(1, pure "C:\\Program Files\\Safari\\Safari.exe"),
(1, pure "C:\\Program Files\\Microsoft\\Edge\\Application\\msedge.exe"),
(1, pure "C:\\Program Files (x86)\\Internet Explorer\\iexplore.exe"),
(1, pure "C:\\Program Files (x86)\\Opera Software\\Opera Stable\\opera.exe")
]
genTextList :: G.Gen [Text]
genTextList = list (R.between (0, 4)) genText
genMaybeTextList :: G.Gen (Maybe [Text])
genMaybeTextList = genMaybe genTextList
genMaybeText :: G.Gen (Maybe Text)
genMaybeText = genMaybe genText
genManualProxy :: G.Gen Proxy
genManualProxy =
Manual
<$> genMaybeText
<*> genMaybeText
<*> genMaybe genSocksProxy
<*> (genMaybe genTextList)
genFromRange :: (Integral a, FiniteBits a) => a -> a -> Gen a
genFromRange lb ub = G.inRange $ R.between (lb, ub)
genInt :: Int -> Int -> G.Gen Int
genInt = genFromRange @Int
genDouble :: Double -> Double -> G.Gen Double
genDouble lb ub = do
-- Generate an integer in [0..1000000].
bits <- G.inRange (R.between (0, 1000000 :: Int))
-- Convert bits to a fraction in [0..1], then interpolate between lb and ub.
let fraction = fromIntegral bits / 1000000
pure $ lb + fraction * (ub - lb)
genSocksProxy :: G.Gen SocksProxy
genSocksProxy = MkSocksProxy <$> genText <*> genInt 1 7
genProxy :: G.Gen Proxy
genProxy =
G.frequency
[ (1, pure Direct),
(1, genManualProxy),
(1, pure AutoDetect),
(1, pure System),
(1, Pac <$> genText)
]
-- Generate random Capabilities
genCapabilities :: G.Gen Capabilities
genCapabilities = do
browserName <- genMEnum
browserVersion <- genMaybe genText
platformName <- genMEnum
strictFileInteractability <- genMaybe genBool
unhandledPromptBehavior <- genMEnum
acceptInsecureCerts <- genMaybe genBool
setWindowRect <- genMaybe genBool
webSocketUrl <- genMaybe genBool
pageLoadStrategy <- genMEnum
proxy <- genMaybe genProxy
timeouts <- genMaybe genTimeouts
vendorSpecific <- genMaybe genVendorSpecific
pure MkCapabilities {..}
options :: TestOptions
options =
TestOptions
{ expectFailure = DontExpectFailure,
overrideVerbose = if wantLogging then Just Verbose else Nothing,
overrideMaxShrinks = Nothing,
overrideNumTests = Just 1000,
overrideMaxRatio = Nothing
}
subEmt :: forall a. (a -> Bool) -> Maybe a -> Maybe a
subEmt f = maybe Nothing (\x -> if f x then Nothing else Just x)
subEmptyTxt :: Maybe Text -> Maybe Text
subEmptyTxt = subEmt T.null
subEmptyList :: Maybe String -> Maybe String
subEmptyList = subEmt null
subEmptyTxtLst :: Maybe [Text] -> Maybe [Text]
subEmptyTxtLst = subEmt emptyTextList
emptyVal :: Value -> Bool
emptyVal = \case
Bool _ -> False
String t -> T.null t
Number _ -> False
Array arr -> null arr
Object o -> KM.null o
Null -> True
subEmtyValueMap :: Maybe (M.Map Text Value) -> Maybe (M.Map Text Value)
subEmtyValueMap = fmap M.fromList . subEmt emptyValList . fmap M.toList
where
emptyValList :: [(Text, Value)] -> Bool
emptyValList ml = null ml || all (\(t, v) -> T.null t || emptyVal v) ml
-- | Substitutes empty fields with Nothing
subEmptyVendor :: Maybe VendorSpecific -> Maybe VendorSpecific
subEmptyVendor = subEmt allPropsNothing . fmap subEmptFields
where
allPropsNothing :: VendorSpecific -> Bool
allPropsNothing = \case
ChromeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12]
EdgeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12]
FirefoxOptions p1 p2 p3 p4 -> allTrue [n p1, n p2, n p3, n p4]
SafariOptions p1 p2 -> allTrue [n p1, n p2]
where
n = isNothing
allTrue :: [Bool] -> Bool
allTrue = all id
subEmptFields :: VendorSpecific -> VendorSpecific
subEmptFields = \case
ChromeOptions {..} ->
ChromeOptions
{ chromeArgs = subEmptyTxtLst chromeArgs,
chromeBinary = subEmptyTxt chromeBinary,
chromeExtensions = subEmptyTxtLst chromeExtensions,
chromeLocalState = subEmtyValueMap chromeLocalState,
chromePrefs = subEmtyValueMap chromePrefs,
chromeDetach,
chromeDebuggerAddress = subEmptyTxt chromeDebuggerAddress,
chromeExcludeSwitches = subEmptyTxtLst chromeExcludeSwitches,
chromeMobileEmulation = subEmptyMobileEmulation chromeMobileEmulation,
chromeMinidumpPath = subEmptyList chromeMinidumpPath,
chromePerfLoggingPrefs = subEmptyPerfLoggingPrefs chromePerfLoggingPrefs,
chromeWindowTypes = subEmptyTxtLst chromeWindowTypes
}
EdgeOptions {..} ->
EdgeOptions
{ edgeArgs = subEmptyTxtLst edgeArgs,
edgeBinary = subEmptyTxt edgeBinary,
edgeExtensions = subEmptyTxtLst edgeExtensions,
edgeLocalState = subEmtyValueMap edgeLocalState,
edgePrefs = subEmtyValueMap edgePrefs,
edgeDetach,
edgeDebuggerAddress = subEmptyTxt edgeDebuggerAddress,
edgeExcludeSwitches = subEmptyTxtLst edgeExcludeSwitches,
edgeMobileEmulation = subEmptyMobileEmulation edgeMobileEmulation,
edgeMinidumpPath = subEmptyList edgeMinidumpPath,
edgePerfLoggingPrefs = subEmptyPerfLoggingPrefs edgePerfLoggingPrefs,
edgeWindowTypes = subEmptyTxtLst edgeWindowTypes
}
FirefoxOptions {..} ->
FirefoxOptions
{ firefoxArgs = subEmptyTxtLst firefoxArgs,
firefoxBinary = subEmptyTxt firefoxBinary,
firefoxProfile = subEmptyTxt firefoxProfile,
firefoxLog
}
s@SafariOptions {} -> s
where
subEmptyMobileEmulation :: Maybe MobileEmulation -> Maybe MobileEmulation
subEmptyMobileEmulation = subEmt emptyMobileEmulation
emptyMobileEmulation :: MobileEmulation -> Bool
emptyMobileEmulation = \case
MkMobileEmulation {deviceName, deviceMetrics, userAgent} ->
emptyTxt deviceName && isNothing deviceMetrics && emptyTxt userAgent
subEmptyPerfLoggingPrefs :: Maybe PerfLoggingPrefs -> Maybe PerfLoggingPrefs
subEmptyPerfLoggingPrefs = subEmt emptyPerfLoggingPrefs
emptyPerfLoggingPrefs :: PerfLoggingPrefs -> Bool
emptyPerfLoggingPrefs = \case
MkPerfLoggingPrefs {enableNetwork, enablePage, enableTimeline, traceCategories, bufferUsageReportingInterval} ->
emptyTxt traceCategories && isNothing bufferUsageReportingInterval && isNothing enableNetwork && isNothing enablePage && isNothing enableTimeline
emptyTxt :: Maybe Text -> Bool
emptyTxt = maybe True T.null
emptyList :: Maybe [a] -> Bool
emptyList = maybe True null
emptyTextList :: [Text] -> Bool
emptyTextList ml = null ml || (all T.null) ml
isNothingProxy :: Proxy -> Bool
isNothingProxy = \case
Direct -> False
Manual httpProxy sslProxy noProxy socksProxy ->
all isNothing [httpProxy, sslProxy] && isNothing noProxy && isNothing socksProxy
AutoDetect -> False
Pac url -> T.null url
System -> False
subEmptyProxy :: Maybe Proxy -> Maybe Proxy
subEmptyProxy p = subEmt isNothingProxy $ subEmptProps <$> p
where
subEmptProps :: Proxy -> Proxy
subEmptProps p' = case p' of
Manual {..} ->
Manual
{ httpProxy = subEmptyTxt httpProxy,
sslProxy = subEmptyTxt sslProxy,
noProxy = subEmptyTxtLst noProxy,
socksProxy
}
Direct -> p'
AutoDetect -> p'
Pac {} -> p'
System -> p'
subEmptyTimeouts :: Maybe Timeouts -> Maybe Timeouts
subEmptyTimeouts = subEmt isNothingTimeouts
where
isNothingTimeouts :: Timeouts -> Bool
isNothingTimeouts = \case
MkTimeouts {..} ->
all isNothing [implicit, pageLoad, script]
emptyFieldsToNothing :: Capabilities -> Capabilities
emptyFieldsToNothing caps@MkCapabilities {..} =
caps
{ browserVersion = subEmptyTxt browserVersion,
vendorSpecific = subEmptyVendor vendorSpecific,
platformName,
acceptInsecureCerts,
pageLoadStrategy,
proxy = subEmptyProxy proxy,
timeouts = subEmptyTimeouts timeouts,
strictFileInteractability,
unhandledPromptBehavior
}
subEmptyCapabilities :: Capabilities -> Capabilities
subEmptyCapabilities caps@MkCapabilities {..} =
caps
{ browserVersion = subEmptyTxt browserVersion,
strictFileInteractability = strictFileInteractability,
acceptInsecureCerts = acceptInsecureCerts,
proxy = subEmptyProxy proxy,
timeouts = subEmptyTimeouts timeouts,
vendorSpecific = subEmptyVendor vendorSpecific
}
jsonEq :: Capabilities -> Maybe Capabilities -> Bool
jsonEq expected =
maybe
False
(\actual -> subEmptyCapabilities expected == subEmptyCapabilities actual)
wantLogging :: Bool
wantLogging = False
log :: String -> Property ()
log = if wantLogging then info else const $ pure ()
test_round_trip :: TestTree
test_round_trip = testPropertyWith options "Roundtrip Capabilities Parsing" $ do
c <- gen genCapabilities
let encoded = encode c
showEncode = jsonToText <$> decode @Value encoded
decoded = decode @Capabilities encoded
asExpected = jsonEq c
log ""
log "Initial Capabilities:"
log $ ppShow c
log ""
log "Encoded Capabilities:"
log $ maybe "Nothing" unpack showEncode
log ""
log "Decoded Capabilities:"
log $ maybe "Nothing" ppShow decoded
assert $ expect True `dot` fn ("matches encoded", asExpected) .$ ("decoded", decoded)
-- >>> unit_websocketUrlFromJSon
unit_websocketUrlFromJSon :: IO ()
unit_websocketUrlFromJSon =
(Success $ Just "ws://127.0.0.1:9222/session/b82f5798-2d37-4555-ac1d-7c70153ad372") === decoded
where
json =
Object
( KM.fromList
[ ( "capabilities",
Object
( KM.fromList
[ ("acceptInsecureCerts", Bool False),
("browserName", String "firefox"),
("browserVersion", String "137.0.2"),
("moz:accessibilityChecks", Bool False),
("moz:buildID", String "20250414091429"),
("moz:geckodriverVersion", String "0.36.0"),
("moz:headless", Bool True),
("moz:platformVersion", String "6.11.0-26-generic"),
("moz:processID", Number 14181.0),
("moz:profile", String "/tmp/rust_mozprofileNltPR1"),
("moz:shutdownTimeout", Number 60000.0),
("moz:webdriverClick", Bool True),
("moz:windowless", Bool False),
("pageLoadStrategy", String "normal"),
("platformName", String "linux"),
("proxy", Object (KM.fromList [])),
("setWindowRect", Bool True),
("strictFileInteractability", Bool False),
( "timeouts",
Object
( KM.fromList
[ ("implicit", Number 0.0),
("pageLoad", Number 300000.0),
("script", Number 30000.0)
]
)
),
("unhandledPromptBehavior", String "dismiss and notify"),
( "userAgent",
String
"Mozilla/5.0 (X11; Linux x86_64; rv:137.0) Gecko/20100101 Firefox/137.0"
),
( "webSocketUrl",
String
"ws://127.0.0.1:9222/session/b82f5798-2d37-4555-ac1d-7c70153ad372"
)
]
)
),
("sessionId", String "b82f5798-2d37-4555-ac1d-7c70153ad372")
]
)
decoded = (.webSocketUrl) <$> fromJSON @SessionResponse json