diff options
author | Volpeon <github@volpeon.ink> | 2023-05-28 08:13:08 +0200 |
---|---|---|
committer | Volpeon <github@volpeon.ink> | 2023-05-28 08:13:08 +0200 |
commit | 8c49a30faa431b8b56a4b4926e7dae56b1311fea (patch) | |
tree | 6a103b49cdfe6df38fadad1f9d59521dd92ebf74 /test/Test/Common.hs | |
parent | Added Node Map Merging algorithm (diff) | |
download | hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.tar.gz hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.tar.bz2 hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.zip |
Completed untested Flattening implementation
Diffstat (limited to 'test/Test/Common.hs')
-rw-r--r-- | test/Test/Common.hs | 96 |
1 files changed, 96 insertions, 0 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 @@ | |||
1 | module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), fetchTest, parseExpansionOptions) where | ||
2 | |||
3 | import Data.JLD.Prelude | ||
4 | |||
5 | import Test.Tasty | ||
6 | import Test.Tasty.ExpectedFailure (ignoreTestBecause) | ||
7 | import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) | ||
8 | |||
9 | import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?)) | ||
10 | import Data.Aeson.Types (prependFailure, typeMismatch) | ||
11 | import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), mimeType, toJldErrorCode) | ||
12 | import Data.JLD.Model.URI (parseUri) | ||
13 | import Data.Maybe (fromJust) | ||
14 | import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) | ||
15 | import Text.URI (URI, mkURI, relativeTo) | ||
16 | |||
17 | data W3CTestOption = W3CTestOption | ||
18 | { w3cTestOptionSpecVersion :: Maybe Text | ||
19 | , w3cTestOptionProcessingMode :: Maybe Text | ||
20 | , w3cTestOptionBase :: Maybe Text | ||
21 | , w3cTestOptionExpandContext :: Maybe Text | ||
22 | } | ||
23 | deriving (Show) | ||
24 | |||
25 | instance 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 | |||
34 | data 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 | |||
43 | instance 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 | |||
53 | newtype W3CTestList = W3CTestList | ||
54 | { w3cSequence :: [W3CTest] | ||
55 | } | ||
56 | deriving (Show) | ||
57 | |||
58 | instance FromJSON W3CTestList where | ||
59 | parseJSON (Object v) = W3CTestList <$> (v .: "sequence") | ||
60 | parseJSON invalid = prependFailure "parsing W3CTestList failed, " (typeMismatch "Object" invalid) | ||
61 | |||
62 | documentLoader :: MonadIO m => DocumentLoader Text m | ||
63 | documentLoader = 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 | |||
69 | fetchTest :: URI -> IO Value | ||
70 | fetchTest 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 | |||
76 | parseExpansionOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) | ||
77 | parseExpansionOptions 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) | ||