1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), documentLoader, fetchTest) where
import Data.JLD.Prelude
import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?))
import Data.Aeson.Types (prependFailure, typeMismatch)
import Data.JLD (DocumentLoader (..), mimeType)
import Data.Maybe (fromJust)
import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI)
import Text.URI (URI)
data W3CTestOption = W3CTestOption
{ w3cTestOptionSpecVersion :: Maybe Text
, w3cTestOptionProcessingMode :: Maybe Text
, w3cTestOptionBase :: Maybe Text
, w3cTestOptionExpandContext :: Maybe Text
, w3cTestOptionCompactArrays :: Maybe Bool
}
deriving (Show)
instance FromJSON W3CTestOption where
parseJSON (Object v) =
W3CTestOption
<$> (v .:? "specVersion")
<*> (v .:? "processingMode")
<*> (v .:? "base")
<*> (v .:? "expandContext")
<*> (v .:? "compactArrays")
parseJSON invalid = prependFailure "parsing W3CTestOption failed, " (typeMismatch "Object" invalid)
data W3CTest = W3CTest
{ w3cTestName :: Text
, w3cTestInput :: Text
, w3cTestExpect :: Maybe Text
, w3cTestExpectErrorCode :: Maybe Text
, w3cTestOption :: Maybe W3CTestOption
}
deriving (Show)
instance FromJSON W3CTest where
parseJSON (Object v) =
W3CTest
<$> (v .: "name")
<*> (v .: "input")
<*> (v .:? "expect")
<*> (v .:? "expectErrorCode")
<*> (v .:? "option")
parseJSON invalid = prependFailure "parsing W3CTest failed, " (typeMismatch "Object" invalid)
newtype W3CTestList = W3CTestList
{ w3cSequence :: [W3CTest]
}
deriving (Show)
instance FromJSON W3CTestList where
parseJSON (Object v) = W3CTestList <$> (v .: "sequence")
parseJSON invalid = prependFailure "parsing W3CTestList failed, " (typeMismatch "Object" invalid)
documentLoader :: MonadIO m => DocumentLoader Text m
documentLoader = DocumentLoader \uri ->
runReq defaultHttpConfig <| case useURI uri of
Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
Nothing -> pure <| Left "Invalid URI"
fetchTest :: URI -> IO Value
fetchTest url = do
let (reqUrl, reqOptions) = fromJust <| useHttpsURI url
runReq defaultHttpConfig do
res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType)
pure <| responseBody res
|
