aboutsummaryrefslogtreecommitdiffstats
path: root/test/Test
diff options
context:
space:
mode:
Diffstat (limited to 'test/Test')
-rw-r--r--test/Test/Common.hs96
-rw-r--r--test/Test/Expansion.hs117
-rw-r--r--test/Test/Flattening.hs51
3 files changed, 162 insertions, 102 deletions
diff --git a/test/Test/Common.hs b/test/Test/Common.hs
new file mode 100644
index 0000000..ffc3264
--- /dev/null
+++ b/test/Test/Common.hs
@@ -0,0 +1,96 @@
1module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), fetchTest, parseExpansionOptions) where
2
3import Data.JLD.Prelude
4
5import Test.Tasty
6import Test.Tasty.ExpectedFailure (ignoreTestBecause)
7import Test.Tasty.HUnit (assertFailure, testCase, (@?=))
8
9import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?))
10import Data.Aeson.Types (prependFailure, typeMismatch)
11import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), mimeType, toJldErrorCode)
12import Data.JLD.Model.URI (parseUri)
13import Data.Maybe (fromJust)
14import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI)
15import Text.URI (URI, mkURI, relativeTo)
16
17data W3CTestOption = W3CTestOption
18 { w3cTestOptionSpecVersion :: Maybe Text
19 , w3cTestOptionProcessingMode :: Maybe Text
20 , w3cTestOptionBase :: Maybe Text
21 , w3cTestOptionExpandContext :: Maybe Text
22 }
23 deriving (Show)
24
25instance FromJSON W3CTestOption where
26 parseJSON (Object v) =
27 W3CTestOption
28 <$> (v .:? "specVersion")
29 <*> (v .:? "processingMode")
30 <*> (v .:? "base")
31 <*> (v .:? "expandContext")
32 parseJSON invalid = prependFailure "parsing W3CTestOption failed, " (typeMismatch "Object" invalid)
33
34data W3CTest = W3CTest
35 { w3cTestName :: Text
36 , w3cTestInput :: Text
37 , w3cTestExpect :: Maybe Text
38 , w3cTestExpectErrorCode :: Maybe Text
39 , w3cTestOption :: Maybe W3CTestOption
40 }
41 deriving (Show)
42
43instance FromJSON W3CTest where
44 parseJSON (Object v) =
45 W3CTest
46 <$> (v .: "name")
47 <*> (v .: "input")
48 <*> (v .:? "expect")
49 <*> (v .:? "expectErrorCode")
50 <*> (v .:? "option")
51 parseJSON invalid = prependFailure "parsing W3CTest failed, " (typeMismatch "Object" invalid)
52
53newtype W3CTestList = W3CTestList
54 { w3cSequence :: [W3CTest]
55 }
56 deriving (Show)
57
58instance FromJSON W3CTestList where
59 parseJSON (Object v) = W3CTestList <$> (v .: "sequence")
60 parseJSON invalid = prependFailure "parsing W3CTestList failed, " (typeMismatch "Object" invalid)
61
62documentLoader :: MonadIO m => DocumentLoader Text m
63documentLoader = DocumentLoader \uri ->
64 runReq defaultHttpConfig <| case useURI uri of
65 Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
66 Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
67 Nothing -> pure <| Left "Invalid URI"
68
69fetchTest :: URI -> IO Value
70fetchTest url = do
71 let (reqUrl, reqOptions) = fromJust <| useHttpsURI url
72 runReq defaultHttpConfig do
73 res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType)
74 pure <| responseBody res
75
76parseExpansionOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO)
77parseExpansionOptions baseUrl inputUrl maybeOptions = do
78 expandContext <- case maybeOptions >>= w3cTestOptionExpandContext of
79 Just rawUrl -> do
80 url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl
81 Just <$> fetchTest url
82 Nothing -> pure Nothing
83
84 let params p =
85 p
86 { jldExpansionParamsDocumentLoader = documentLoader
87 , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cTestOptionProcessingMode of
88 Just "json-ld-1.0" -> JLD1_0
89 Just "json-ld-1.1" -> JLD1_1
90 _ -> jldExpansionParamsProcessingMode p
91 , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p
92 }
93
94 pure (expandBaseUrl, params)
95 where
96 expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cTestOptionBase =<< maybeOptions)
diff --git a/test/Test/Expansion.hs b/test/Test/Expansion.hs
index 89024c6..b5b1e07 100644
--- a/test/Test/Expansion.hs
+++ b/test/Test/Expansion.hs
@@ -1,134 +1,47 @@
1module Test.Expansion (W3CExpansionTestList, expansionTests) where 1module Test.Expansion (expansionTests) where
2 2
3import Data.JLD.Prelude 3import Data.JLD.Prelude
4 4
5import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode)
6import Data.JLD.Model.URI (parseUri)
7
8import Test.Tasty 5import Test.Tasty
9import Test.Tasty.ExpectedFailure (ignoreTestBecause) 6import Test.Tasty.ExpectedFailure (ignoreTestBecause)
10import Test.Tasty.HUnit 7import Test.Tasty.HUnit
11 8
12import Data.Aeson (FromJSON, Value (..), (.:), (.:?)) 9import Data.JLD (expand, toJldErrorCode)
13import Data.Aeson.Types (FromJSON (..), prependFailure, typeMismatch)
14import Data.Maybe (fromJust) 10import Data.Maybe (fromJust)
15import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) 11import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions)
16import Text.URI (URI, mkURI, relativeTo) 12import Text.URI (mkURI, relativeTo)
17
18data W3CExpansionTestOption = W3CExpansionTestOption
19 { w3cExpansionTestOptionSpecVersion :: Maybe Text
20 , w3cExpansionTestOptionProcessingMode :: Maybe Text
21 , w3cExpansionTestOptionBase :: Maybe Text
22 , w3cExpansionTestOptionExpandContext :: Maybe Text
23 }
24 deriving (Show)
25
26instance FromJSON W3CExpansionTestOption where
27 parseJSON (Object v) =
28 W3CExpansionTestOption
29 <$> (v .:? "specVersion")
30 <*> (v .:? "processingMode")
31 <*> (v .:? "base")
32 <*> (v .:? "expandContext")
33 parseJSON invalid = prependFailure "parsing W3CExpansionTestOption failed, " (typeMismatch "Object" invalid)
34
35data W3CExpansionTest = W3CExpansionTest
36 { w3cExpansionTestName :: Text
37 , w3cExpansionTestInput :: Text
38 , w3cExpansionTestExpect :: Maybe Text
39 , w3cExpansionTestExpectErrorCode :: Maybe Text
40 , w3cExpansionTestOption :: Maybe W3CExpansionTestOption
41 }
42 deriving (Show)
43
44instance FromJSON W3CExpansionTest where
45 parseJSON (Object v) =
46 W3CExpansionTest
47 <$> (v .: "name")
48 <*> (v .: "input")
49 <*> (v .:? "expect")
50 <*> (v .:? "expectErrorCode")
51 <*> (v .:? "option")
52 parseJSON invalid = prependFailure "parsing W3CExpansionTest failed, " (typeMismatch "Object" invalid)
53
54newtype W3CExpansionTestList = W3CExpansionTestList
55 { w3cExpansionSequence :: [W3CExpansionTest]
56 }
57 deriving (Show)
58
59instance FromJSON W3CExpansionTestList where
60 parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence")
61 parseJSON invalid = prependFailure "parsing W3CExpansionTestList failed, " (typeMismatch "Object" invalid)
62 13
63documentLoader :: MonadIO m => DocumentLoader Text m 14expansionTests :: W3CTestList -> TestTree
64documentLoader = DocumentLoader \uri -> 15expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> zip (w3cSequence testList) [1 ..]
65 runReq defaultHttpConfig <| case useURI uri of
66 Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
67 Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType)
68 Nothing -> pure <| Left "Invalid URI"
69 16
70fetchTest :: URI -> IO Value 17expansionTest :: W3CTest -> Int -> TestTree
71fetchTest url = do 18expansionTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName)
72 let (reqUrl, reqOptions) = fromJust <| useHttpsURI url 19 | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption =
73 runReq defaultHttpConfig do
74 res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType)
75 pure <| responseBody res
76
77parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO)
78parseOptions baseUrl inputUrl maybeOptions = do
79 expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of
80 Just rawUrl -> do
81 url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl
82 Just <$> fetchTest url
83 Nothing -> pure Nothing
84
85 let params p =
86 p
87 { jldExpansionParamsDocumentLoader = documentLoader
88 , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of
89 Just "json-ld-1.0" -> JLD1_0
90 Just "json-ld-1.1" -> JLD1_1
91 _ -> jldExpansionParamsProcessingMode p
92 , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p
93 }
94
95 pure (expandBaseUrl, params)
96 where
97 expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions)
98
99expansionTests :: W3CExpansionTestList -> TestTree
100expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..])
101
102expansionTest :: W3CExpansionTest -> Int -> TestTree
103expansionTest W3CExpansionTest{..} (show .> (<> ". " <> toString w3cExpansionTestName) -> testName)
104 | Just "json-ld-1.0" <- w3cExpansionTestOptionSpecVersion =<< w3cExpansionTestOption =
105 ignoreTestBecause "specVersion json-ld-1.0 is not supported" 20 ignoreTestBecause "specVersion json-ld-1.0 is not supported"
106 <| testCase testName do pure () 21 <| testCase testName do pure ()
107 -- 22 --
108 | Just expectUrlRaw <- w3cExpansionTestExpect = 23 | Just expectUrlRaw <- w3cTestExpect =
109 testCase testName do 24 testCase testName do
110 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" 25 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
111 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput 26 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput
112 expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw 27 expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw
113 28
114 inputJld <- fetchTest inputUrl 29 inputJld <- fetchTest inputUrl
115 expectJld <- fetchTest expectUrl 30 expectJld <- fetchTest expectUrl
116 31
117 (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption 32 (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption
118 (result, _) <- expand inputJld expandBaseUrl params 33 (result, _) <- expand inputJld expandBaseUrl params
119 34
120 -- pTraceShowM (expectJLD, result)
121
122 result @?= Right expectJld 35 result @?= Right expectJld
123 -- 36 --
124 | Just expectErrorRaw <- w3cExpansionTestExpectErrorCode = 37 | Just expectErrorRaw <- w3cTestExpectErrorCode =
125 testCase testName do 38 testCase testName do
126 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" 39 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
127 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput 40 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput
128 41
129 inputJld <- fetchTest inputUrl 42 inputJld <- fetchTest inputUrl
130 43
131 (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption 44 (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption
132 (result, _) <- expand inputJld expandBaseUrl params 45 (result, _) <- expand inputJld expandBaseUrl params
133 46
134 (result |> first toJldErrorCode) @?= Left expectErrorRaw 47 (result |> first toJldErrorCode) @?= Left expectErrorRaw
diff --git a/test/Test/Flattening.hs b/test/Test/Flattening.hs
new file mode 100644
index 0000000..bc64b88
--- /dev/null
+++ b/test/Test/Flattening.hs
@@ -0,0 +1,51 @@
1module Test.Flattening (flatteningTests) where
2
3import Data.JLD.Prelude
4
5import Test.Tasty
6import Test.Tasty.ExpectedFailure (ignoreTestBecause)
7import Test.Tasty.HUnit
8
9import Data.JLD (expand, flatten, toJldErrorCode)
10import Data.Maybe (fromJust)
11import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions)
12import Text.URI (mkURI, relativeTo)
13
14flatteningTests :: W3CTestList -> TestTree
15flatteningTests testList = testGroup "Flattening" <| uncurry flatteningTest <$> zip (w3cSequence testList) [1 ..]
16
17flatteningTest :: W3CTest -> Int -> TestTree
18flatteningTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName)
19 | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption =
20 ignoreTestBecause "specVersion json-ld-1.0 is not supported"
21 <| testCase testName do pure ()
22 --
23 | Just expectUrlRaw <- w3cTestExpect =
24 testCase testName do
25 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
26 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput
27 expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw
28
29 inputJld <- fetchTest inputUrl
30 expectJld <- fetchTest expectUrl
31
32 (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption
33 (result, _) <- flatten inputJld expandBaseUrl params
34
35 result @?= Right expectJld
36 --
37 | Just expectErrorRaw <- w3cTestExpectErrorCode =
38 testCase testName do
39 baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/"
40 inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput
41
42 inputJld <- fetchTest inputUrl
43
44 (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption
45 (result, _) <- flatten inputJld expandBaseUrl params
46
47 (result |> first toJldErrorCode) @?= Left expectErrorRaw
48 --
49 | otherwise =
50 testCase testName do
51 assertFailure <| "Unhandled test type"