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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
module Test.Expansion (W3CExpansionTestList, expansionTests) where
import Data.JLD.Prelude
import Data.JLD (DocumentLoader (..), JLDExpandParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode)
import Data.JLD.Model.URI (parseUri)
import Data.JLD.Monad (JLDEnv (..), newEnv)
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit
import Data.Aeson (FromJSON, Value (..), (.:), (.:?))
import Data.Aeson.Types (FromJSON (..), prependFailure, typeMismatch)
import Data.Maybe (fromJust)
import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI)
import Text.URI (URI, mkURI, relativeTo)
data W3CExpansionTestOption = W3CExpansionTestOption
{ w3cExpansionTestOptionSpecVersion :: Maybe Text
, w3cExpansionTestOptionProcessingMode :: Maybe Text
, w3cExpansionTestOptionBase :: Maybe Text
, w3cExpansionTestOptionExpandContext :: Maybe Text
}
deriving (Show)
instance FromJSON W3CExpansionTestOption where
parseJSON (Object v) =
W3CExpansionTestOption
<$> (v .:? "specVersion")
<*> (v .:? "processingMode")
<*> (v .:? "base")
<*> (v .:? "expandContext")
parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid)
data W3CExpansionTest = W3CExpansionTest
{ w3cExpansionTestName :: Text
, w3cExpansionTestInput :: Text
, w3cExpansionTestExpect :: Maybe Text
, w3cExpansionTestExpectErrorCode :: Maybe Text
, w3cExpansionTestOption :: Maybe W3CExpansionTestOption
}
deriving (Show)
instance FromJSON W3CExpansionTest where
parseJSON (Object v) =
W3CExpansionTest
<$> (v .: "name")
<*> (v .: "input")
<*> (v .:? "expect")
<*> (v .:? "expectErrorCode")
<*> (v .:? "option")
parseJSON invalid = prependFailure "parsing Coord failed, " (typeMismatch "Object" invalid)
newtype W3CExpansionTestList = W3CExpansionTestList
{ w3cExpansionSequence :: [W3CExpansionTest]
}
deriving (Show)
instance FromJSON W3CExpansionTestList where
parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence")
parseJSON invalid = prependFailure "parsing Coord 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
parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpandParams () IO -> JLDExpandParams Text IO)
parseOptions baseUrl inputUrl maybeOptions = do
expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of
Just rawUrl -> do
url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl
Just <$> fetchTest url
Nothing -> pure Nothing
let params p =
p
{ jldExpandParamsEnv = env'
, jldExpandParamsExpandContext = expandContext <|> jldExpandParamsExpandContext p
}
pure (expandBaseUrl, params)
where
expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions)
env = newEnv \e -> e{jldEnvDocumentLoader = documentLoader}
env' = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of
Just "json-ld-1.0" -> env{jldEnvProcessingMode = JLD1_0}
Just "json-ld-1.1" -> env{jldEnvProcessingMode = JLD1_1}
_ -> env
expansionTests :: W3CExpansionTestList -> TestTree
expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..])
expansionTest :: W3CExpansionTest -> Int -> TestTree
expansionTest W3CExpansionTest{..} (show .> (<> ". " <> toString w3cExpansionTestName) -> testName)
| Just "json-ld-1.0" <- w3cExpansionTestOptionSpecVersion =<< w3cExpansionTestOption =
ignoreTestBecause "specVersion json-ld-1.0 is not supported"
<| testCase testName do pure ()
--
| Just expectUrlRaw <- w3cExpansionTestExpect =
testCase testName do
baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput
expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw
inputJld <- fetchTest inputUrl
expectJld <- fetchTest expectUrl
(expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption
(result, _) <- expand inputJld expandBaseUrl params
-- pTraceShowM (expectJLD, result)
result @?= Right expectJld
--
| Just expectErrorRaw <- w3cExpansionTestExpectErrorCode =
testCase testName do
baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput
inputJld <- fetchTest inputUrl
(expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption
(result, _) <- expand inputJld expandBaseUrl params
(result |> first toJldErrorCode) @?= Left expectErrorRaw
--
| otherwise =
testCase testName do
assertFailure <| "Unhandled test type"
|
