Successfully perform protected test requests to gargantext

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

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" } |]

test/Test/Utils.hs

+{-# 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