From 8c49a30faa431b8b56a4b4926e7dae56b1311fea Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 08:13:08 +0200 Subject: Completed untested Flattening implementation --- test/Spec.hs | 23 ++++++---- test/Test/Common.hs | 96 +++++++++++++++++++++++++++++++++++++++ test/Test/Expansion.hs | 117 +++++++----------------------------------------- test/Test/Flattening.hs | 51 +++++++++++++++++++++ 4 files changed, 177 insertions(+), 110 deletions(-) create mode 100644 test/Test/Common.hs create mode 100644 test/Test/Flattening.hs (limited to 'test') diff --git a/test/Spec.hs b/test/Spec.hs index c58bbfa..c85ac53 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,24 +1,31 @@ import Data.JLD.Prelude -import Data.JLD.Mime (mimeType) -import Test.Expansion (W3CExpansionTestList, expansionTests) - import Test.Tasty +import Data.JLD.Mime (mimeType) +import Test.Common (W3CTestList) +import Test.Expansion (expansionTests) +import Test.Flattening (flatteningTests) + import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, https, jsonResponse, req, responseBody, runReq, (/:)) -tests :: W3CExpansionTestList -> TestTree -tests jldExpansionTestList = +tests :: W3CTestList -> W3CTestList -> TestTree +tests expansionTestList flatteningTestList = testGroup "Tests" - [ expansionTests jldExpansionTestList + [ expansionTests expansionTestList + , flatteningTests flatteningTestList ] main :: IO () main = do - jldExpansionTestList <- runReq defaultHttpConfig do + expansionTestList <- runReq defaultHttpConfig do responseBody <$> req GET w3cExpansionTestListUrl NoReqBody jsonResponse (header "Accept" mimeType) - defaultMain <| tests jldExpansionTestList + flatteningTestList <- runReq defaultHttpConfig do + responseBody <$> req GET w3cFlatteningTestListUrl NoReqBody jsonResponse (header "Accept" mimeType) + + defaultMain <| tests expansionTestList flatteningTestList where w3cExpansionTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "expand-manifest.jsonld" + w3cFlatteningTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "flatten-manifest.jsonld" 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 @@ +module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), fetchTest, parseExpansionOptions) where + +import Data.JLD.Prelude + +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?)) +import Data.Aeson.Types (prependFailure, typeMismatch) +import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), mimeType, toJldErrorCode) +import Data.JLD.Model.URI (parseUri) +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 W3CTestOption = W3CTestOption + { w3cTestOptionSpecVersion :: Maybe Text + , w3cTestOptionProcessingMode :: Maybe Text + , w3cTestOptionBase :: Maybe Text + , w3cTestOptionExpandContext :: Maybe Text + } + deriving (Show) + +instance FromJSON W3CTestOption where + parseJSON (Object v) = + W3CTestOption + <$> (v .:? "specVersion") + <*> (v .:? "processingMode") + <*> (v .:? "base") + <*> (v .:? "expandContext") + 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 + +parseExpansionOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) +parseExpansionOptions baseUrl inputUrl maybeOptions = do + expandContext <- case maybeOptions >>= w3cTestOptionExpandContext of + Just rawUrl -> do + url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl + Just <$> fetchTest url + Nothing -> pure Nothing + + let params p = + p + { jldExpansionParamsDocumentLoader = documentLoader + , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cTestOptionProcessingMode of + Just "json-ld-1.0" -> JLD1_0 + Just "json-ld-1.1" -> JLD1_1 + _ -> jldExpansionParamsProcessingMode p + , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p + } + + pure (expandBaseUrl, params) + where + 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 @@ -module Test.Expansion (W3CExpansionTestList, expansionTests) where +module Test.Expansion (expansionTests) where import Data.JLD.Prelude -import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) -import Data.JLD.Model.URI (parseUri) - 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.JLD (expand, toJldErrorCode) 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 W3CExpansionTestOption 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 W3CExpansionTest 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 W3CExpansionTestList failed, " (typeMismatch "Object" invalid) +import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) +import Text.URI (mkURI, relativeTo) -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" +expansionTests :: W3CTestList -> TestTree +expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> zip (w3cSequence testList) [1 ..] -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, JLDExpansionParams () IO -> JLDExpansionParams 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 - { jldExpansionParamsDocumentLoader = documentLoader - , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of - Just "json-ld-1.0" -> JLD1_0 - Just "json-ld-1.1" -> JLD1_1 - _ -> jldExpansionParamsProcessingMode p - , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p - } - - pure (expandBaseUrl, params) - where - expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions) - -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 = +expansionTest :: W3CTest -> Int -> TestTree +expansionTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName) + | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption = ignoreTestBecause "specVersion json-ld-1.0 is not supported" <| testCase testName do pure () -- - | Just expectUrlRaw <- w3cExpansionTestExpect = + | Just expectUrlRaw <- w3cTestExpect = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" - inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw inputJld <- fetchTest inputUrl expectJld <- fetchTest expectUrl - (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params - -- pTraceShowM (expectJLD, result) - result @?= Right expectJld -- - | Just expectErrorRaw <- w3cExpansionTestExpectErrorCode = + | Just expectErrorRaw <- w3cTestExpectErrorCode = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" - inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput inputJld <- fetchTest inputUrl - (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params (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 @@ +module Test.Flattening (flatteningTests) where + +import Data.JLD.Prelude + +import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.HUnit + +import Data.JLD (expand, flatten, toJldErrorCode) +import Data.Maybe (fromJust) +import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) +import Text.URI (mkURI, relativeTo) + +flatteningTests :: W3CTestList -> TestTree +flatteningTests testList = testGroup "Flattening" <| uncurry flatteningTest <$> zip (w3cSequence testList) [1 ..] + +flatteningTest :: W3CTest -> Int -> TestTree +flatteningTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName) + | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption = + ignoreTestBecause "specVersion json-ld-1.0 is not supported" + <| testCase testName do pure () + -- + | Just expectUrlRaw <- w3cTestExpect = + testCase testName do + baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput + expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw + + inputJld <- fetchTest inputUrl + expectJld <- fetchTest expectUrl + + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption + (result, _) <- flatten inputJld expandBaseUrl params + + result @?= Right expectJld + -- + | Just expectErrorRaw <- w3cTestExpectErrorCode = + testCase testName do + baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput + + inputJld <- fetchTest inputUrl + + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption + (result, _) <- flatten inputJld expandBaseUrl params + + (result |> first toJldErrorCode) @?= Left expectErrorRaw + -- + | otherwise = + testCase testName do + assertFailure <| "Unhandled test type" -- cgit v1.2.3-70-g09d2