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