Init

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 @@
+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"