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