diff --git a/gargantext.cabal b/gargantext.cabal index 3cbf4eb17cb7f18dbb0ff7cb937738e882733a27..bf68f0adf2026a806360c5e0171c18a45625a1e0 100644 --- a/gargantext.cabal +++ b/gargantext.cabal @@ -972,6 +972,7 @@ test-suite garg-test-tasty , tasty-hunit , tasty-quickcheck , tasty-smallcheck + , template-haskell , text ^>= 1.2.4.1 , time ^>= 1.9.3 , tmp-postgres >= 1.34.1 && < 1.35 @@ -994,6 +995,7 @@ test-suite garg-test-hspec Test.Database.Operations.DocumentSearch Test.Database.Setup Test.Database.Types + Test.Utils Paths_gargantext hs-source-dirs: test @@ -1072,6 +1074,7 @@ test-suite garg-test-hspec , tasty-hunit , tasty-quickcheck , tasty-smallcheck + , template-haskell , text ^>= 1.2.4.1 , time ^>= 1.9.3 , tmp-postgres >= 1.34.1 && < 1.35 diff --git a/test/Test/API/Private.hs b/test/Test/API/Private.hs index 95e2df2151f4bc5d53e17c85241b8b582cc7bb12..5ddc1ec628972f407a2d582c5295328425f830ea 100644 --- a/test/Test/API/Private.hs +++ b/test/Test/API/Private.hs @@ -34,6 +34,7 @@ import Data.ByteString (ByteString) import Network.Wai.Test (SResponse) import Network.HTTP.Types import qualified Data.ByteString.Lazy as L +import Test.Utils (jsonFragment, shouldRespondWith') type Env = ((TestEnv, Wai.Port), Application) @@ -49,7 +50,7 @@ protected :: Token -> Method -> ByteString -> L.ByteString -> WaiSession () SRes protected tkn mth url payload = request mth url [ (hAccept, "application/json;charset=utf-8") , (hContentType, "application/json") - , (hAuthorization, TE.encodeUtf8 tkn) + , (hAuthorization, "Bearer " <> TE.encodeUtf8 tkn) ] payload getJSON :: ByteString -> WaiSession () SResponse @@ -118,5 +119,5 @@ tests = sequential $ aroundAll withTestDBAndPort $ do it "allows 'alice' to see her own node info" $ \((_testEnv, port), app) -> do withApplication app $ do withValidLogin port "alice" (GargPassword "alice") $ \token -> do - protected token "GET" (mkUrl port "/node/1") "" `shouldRespondWith` [json| { } |] - + protected token "GET" (mkUrl port "/node/8") "" + `shouldRespondWith'` [jsonFragment| {"id":8,"user_id":2,"name":"alice" } |] diff --git a/test/Test/Utils.hs b/test/Test/Utils.hs index aa76fe5002edc6703d2694fd26df4dce270080c5..703743f3f83bd30aa353b19c0683cbe9645972dc 100644 --- a/test/Test/Utils.hs +++ b/test/Test/Utils.hs @@ -1,9 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Utils where -import Prelude import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.QQ.Simple (aesonQQ) +import Data.Char (isSpace) +import Language.Haskell.TH.Quote +import Network.Wai.Test +import Prelude +import Test.Hspec.Expectations +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Test.Hspec.Wai.Matcher import Test.Tasty.HUnit +import qualified Data.ByteString.Char8 as B +import qualified Data.HashMap.Strict as HM -- | Marks the input 'Assertion' as pending, by ignoring any exception -- thrown by it. @@ -11,3 +26,51 @@ pending :: String -> Assertion -> Assertion pending reason act = act `catch` (\(e :: SomeException) -> do putStrLn $ "PENDING: " <> reason putStrLn (displayException e)) + +jsonFragment :: QuasiQuoter +jsonFragment = QuasiQuoter { + quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|] +, quotePat = const $ error "No quotePat defined for jsonFragment" +, quoteType = const $ error "No quoteType defined for jsonFragment" +, quoteDec = const $ error "No quoteDec defined for jsonFragment" +} + +newtype JsonFragmentResponseMatcher = JsonFragmentResponseMatcher { getJsonMatcher :: ResponseMatcher } + +shouldRespondWith' :: HasCallStack + => WaiSession st SResponse + -> JsonFragmentResponseMatcher + -> WaiExpectation st +shouldRespondWith' action matcher = do + r <- action + forM_ (match r (getJsonMatcher matcher)) (liftIO . expectationFailure) + +instance FromValue JsonFragmentResponseMatcher where + fromValue = JsonFragmentResponseMatcher . ResponseMatcher 200 [matchHeader] . containsJSON + where + matchHeader = MatchHeader $ \headers _body -> + case lookup "Content-Type" headers of + Just h | isJSON h -> Nothing + _ -> Just $ unlines [ + "missing header:" + , formatHeader ("Content-Type", "application/json") + ] + isJSON c = media == "application/json" && parameters `elem` ignoredParameters + where + (media, parameters) = let (m, p) = breakAt ';' c in (strip m, strip p) + ignoredParameters = ["", "charset=utf-8"] + + breakAt c = fmap (B.drop 1) . B.break (== c) + strip = B.reverse . B.dropWhile isSpace . B.reverse . B.dropWhile isSpace + +containsJSON :: Value -> MatchBody +containsJSON expected = MatchBody matcher + where + matcher headers actualBody = case decode actualBody of + Just actual | expected `isSubsetOf` actual -> Nothing + _ -> let MatchBody m = bodyEquals (encode expected) in m headers actualBody + + isSubsetOf :: Value -> Value -> Bool + isSubsetOf (Object sub) (Object sup) = + all (\(key, value) -> HM.lookup key sup == Just value) (HM.toList sub) + isSubsetOf x y = x == y