From 11d0fb47c292a0ca25a9c377499d2b221d97a5cb Mon Sep 17 00:00:00 2001 From: Volpeon Date: Fri, 26 May 2023 07:40:13 +0200 Subject: Init --- test/Spec.hs | 24 +++++++++ test/Test/Expansion.hs | 141 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 165 insertions(+) create mode 100644 test/Spec.hs create mode 100644 test/Test/Expansion.hs (limited to 'test') diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..c58bbfa --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,24 @@ +import Data.JLD.Prelude + +import Data.JLD.Mime (mimeType) +import Test.Expansion (W3CExpansionTestList, expansionTests) + +import Test.Tasty + +import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, https, jsonResponse, req, responseBody, runReq, (/:)) + +tests :: W3CExpansionTestList -> TestTree +tests jldExpansionTestList = + testGroup + "Tests" + [ expansionTests jldExpansionTestList + ] + +main :: IO () +main = do + jldExpansionTestList <- runReq defaultHttpConfig do + responseBody <$> req GET w3cExpansionTestListUrl NoReqBody jsonResponse (header "Accept" mimeType) + + defaultMain <| tests jldExpansionTestList + where + w3cExpansionTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "expand-manifest.jsonld" 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 @@ +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" -- cgit v1.2.3-70-g09d2