Merge remote-tracking branch 'origin/adinapoli/fix-datafield-instance' into dev-merge

gargantext.cabal

@@ -43,6 +43,8 @@ library
       Gargantext.API.Ngrams.Tools
       Gargantext.API.Ngrams.Types
       Gargantext.API.Node
+      Gargantext.API.Node.Corpus.New
+      Gargantext.API.Node.Corpus.Types
       Gargantext.API.Node.File
       Gargantext.API.Node.Share
       Gargantext.API.Prelude
@@ -149,11 +151,9 @@ library
       Gargantext.API.Node.Corpus.Annuaire
       Gargantext.API.Node.Corpus.Export
       Gargantext.API.Node.Corpus.Export.Types
-      Gargantext.API.Node.Corpus.New
       Gargantext.API.Node.Corpus.New.File
       Gargantext.API.Node.Corpus.New.Types
       Gargantext.API.Node.Corpus.Searx
-      Gargantext.API.Node.Corpus.Types
       Gargantext.API.Node.Document.Export
       Gargantext.API.Node.Document.Export.Types
       Gargantext.API.Node.DocumentsFromWriteNodes
@@ -863,6 +863,7 @@ test-suite garg-test
       Ngrams.NLP
       Ngrams.Query
       Ngrams.Query.PaginationCorpus
+      Offline.JSON
       Parsers.Date
       Parsers.Types
       Parsers.WOS
@@ -917,6 +918,7 @@ test-suite garg-test
     , patches-class
     , patches-map
     , quickcheck-instances
+    , raw-strings-qq
     , servant-job
     , stm
     , tasty

package.yaml

@@ -71,6 +71,8 @@ library:
   - Gargantext.API.Ngrams.Tools
   - Gargantext.API.Ngrams.Types
   - Gargantext.API.Node
+  - Gargantext.API.Node.Corpus.New
+  - Gargantext.API.Node.Corpus.Types
   - Gargantext.API.Node.File
   - Gargantext.API.Node.Share
   - Gargantext.API.Prelude
@@ -536,6 +538,7 @@ tests:
      - patches-map
      - duckling
      - quickcheck-instances
+     - raw-strings-qq
      - servant-job
      - stm
      - tasty

src-test/Main.hs

@@ -22,6 +22,7 @@ import qualified Parsers.Date            as PD
 import qualified Graph.Clustering        as Graph
 import qualified Utils.Crypto            as Crypto
 import qualified Utils.Jobs              as Jobs
+import qualified Offline.JSON            as JSON
 
 import Test.Tasty
 import Test.Tasty.Hspec
@@ -44,6 +45,7 @@ main = do
     , jobsSpec
     , NgramsQuery.tests
     , CorpusQuery.tests
+    , JSON.tests
     ]
 --    Occ.parsersTest
 --    Lang.ngramsExtractionTest FR

src-test/Offline/JSON.hs

+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Offline.JSON (tests) where
+
+import Data.Aeson
+import Data.Either
+import Gargantext.API.Node.Corpus.New
+import Gargantext.API.Node.Corpus.Types
+import Prelude
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import Text.RawString.QQ
+import qualified Data.ByteString.Lazy.Char8 as C8
+
+jsonRoundtrip :: (Show a, FromJSON a, ToJSON a, Eq a) => a -> Property
+jsonRoundtrip a = eitherDecode (encode a) === Right a
+
+tests :: TestTree
+tests = testGroup "JSON" [
+    testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield)
+  , testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery)
+  , testCase "WithQuery frontend compliance" testWithQueryFrontend
+  ]
+
+testWithQueryFrontend :: Assertion
+testWithQueryFrontend = do
+  assertBool "JSON instance will break frontend!"
+    (isRight $ eitherDecode @WithQuery (C8.pack cannedWithQueryPayload))
+
+-- The aim of this type is to catch regressions in the frontend serialisation; this
+-- is what the frontend currently expects, and therefore if we were to change the JSON
+-- instances, this test would fail, and we will be notified.
+cannedWithQueryPayload :: String
+cannedWithQueryPayload = [r| {"query":"Haskell","node_id":138,"lang":"EN","flowListWith":{"type":"MyListsFirst"},"datafield":"External Arxiv","databases":"Arxiv"} |]

src/Gargantext/API/Node/Corpus/New.hs

@@ -144,7 +144,7 @@ data WithQuery = WithQuery
   , _wq_node_id      :: !Int
   , _wq_flowListWith :: !FlowSocialListWith
   }
-  deriving Generic
+  deriving (Show, Eq, Generic)
 
 makeLenses ''WithQuery
 instance FromJSON WithQuery where
@@ -154,6 +154,14 @@ instance ToJSON WithQuery where
 instance ToSchema WithQuery where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
 
+instance Arbitrary WithQuery where
+  arbitrary = WithQuery <$> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+
 ------------------------------------------------------------------------
 
 type AddWithQuery = Summary "Add with Query to corpus endpoint"

src/Gargantext/API/Node/Corpus/Types.hs

@@ -3,11 +3,14 @@
 module Gargantext.API.Node.Corpus.Types where
 
 import Control.Lens hiding (elements, Empty)
+import Control.Monad.Fail (fail)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Monoid (mempty)
 import Data.Swagger
 import GHC.Generics (Generic)
+import Test.QuickCheck
+import qualified Data.Text as T
 
 import Gargantext.Prelude
 
@@ -23,6 +26,9 @@ data Database = Empty
               | Isidore
   deriving (Eq, Show, Generic, Enum, Bounded)
 
+instance Arbitrary Database where
+  arbitrary = arbitraryBoundedEnum
+
 deriveJSON (unPrefix "") ''Database
 instance ToSchema Database where
   declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
@@ -42,24 +48,27 @@ data Datafield = Gargantext
                | Files
   deriving (Eq, Show, Generic)
 
-instance FromJSON Datafield
-instance ToJSON Datafield
--- instance FromJSON Datafield where
---   parseJSON = withText "Datafield" $ \text ->
---     case text of
---       "Gargantext" -> pure Gargantext
---       "Web" -> pure Web
---       "Files" -> pure Files
---       v ->
---         let (preExternal, _, postExternal) = v =~ ("External " :: Text) :: (Text, Text, Text)
---         in
---         if preExternal == "" then do
---           db <- parseJSON $ String postExternal
---           pure $ External db
---         else fail $ "Cannot match patterh 'External <db>' for string " ++ (T.unpack v)
--- instance ToJSON Datafield where
---   toJSON (External db) = toJSON $ "External " ++ (show db)
---   toJSON s = toJSON $ show s
+instance FromJSON Datafield where
+  parseJSON = withText "Datafield" $ \text ->
+    case text of
+      "Gargantext"
+        -> pure Gargantext
+      "Web"
+        -> pure Web
+      "Files"
+        -> pure Files
+      v -> case T.breakOnEnd " " v of
+          ("External ", dbName)
+            -> External <$> parseJSON (String dbName)
+          _ -> fail $ "Cannot match patterh 'External <db>' for string " <> T.unpack v
+
+instance ToJSON Datafield where
+  toJSON (External db) = toJSON $ "External " <> show db
+  toJSON s = toJSON $ show s
+
+instance Arbitrary Datafield where
+  arbitrary = oneof [pure Gargantext, pure Web, pure Files, External <$> arbitrary]
+
 instance ToSchema Datafield where
   declareNamedSchema _ = do
     return $ NamedSchema (Just "Datafield") $ mempty

src/Gargantext/Core.hs

@@ -24,6 +24,7 @@ import Data.Tuple.Extra (swap)
 import GHC.Generics (Generic)
 import Gargantext.Prelude
 import Servant.API
+import Test.QuickCheck
 import qualified Data.Map as Map
 
 ------------------------------------------------------------------------
@@ -80,8 +81,11 @@ instance ToHttpApiData Lang where
   toUrlPiece = pack . show
 instance Hashable Lang
 
+instance Arbitrary Lang where
+  arbitrary = arbitraryBoundedEnum
+
 allLangs :: [Lang]
-allLangs = [minBound ..]
+allLangs = [minBound .. maxBound]
 
 class HasDBid a where
   toDBid   :: a   -> Int

src/Gargantext/Core/Text/Corpus/Query.hs

@@ -21,6 +21,7 @@ import           Gargantext.API.Admin.Orchestrator.Types
 import           Gargantext.Core.Types
 import           Prelude
 import           Text.ParserCombinators.Parsec
+import           Test.QuickCheck
 import qualified Data.Aeson                               as Aeson
 import           Data.BoolExpr                            as BoolExpr
 import           Data.BoolExpr.Parser                     as BoolExpr
@@ -37,6 +38,9 @@ newtype RawQuery = RawQuery { getRawQuery :: T.Text }
                    , Aeson.FromJSON, Aeson.ToJSON
                    , Swagger.ToParamSchema, Swagger.ToSchema)
 
+instance Arbitrary RawQuery where
+  arbitrary = RawQuery <$> arbitrary
+
 -- | A limit to the number of results we want to retrieve.
 newtype Limit = Limit { getLimit :: Int }
   deriving newtype ( Show, Eq, Num

src/Gargantext/Core/Text/List/Social.hs

@@ -34,13 +34,12 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Tree (NodeMode(Private), HasTreeError)
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
+import Test.QuickCheck
 import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
 import qualified Data.List       as List
 import qualified Data.Map.Strict as Map
-import qualified Data.Scientific as Scientific
 import qualified Data.Text       as T
 import qualified Data.Vector     as V
-import qualified Prelude
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | Main parameters
@@ -61,16 +60,28 @@ instance FromJSON FlowSocialListWith where
     case typ of
       "MyListsFirst"     -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
       "OtherListsFirst"  -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
+      "OthersFirst"      -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
       "SelectedLists"    -> pure $ FlowSocialListWithLists    { fslw_lists    = value       }
-      "NoList"           -> pure $ NoList True
+      "NoList"           -> do
+        mkList <- v .: "makeList"
+        pure $ NoList mkList
       _                  -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
   parseJSON _ = mzero
 instance ToJSON FlowSocialListWith where
   toJSON (FlowSocialListWithPriority { fslw_priority = MySelfFirst }) = object [ ("type", String "MyListsFirst") ]
-  toJSON (FlowSocialListWithPriority { fslw_priority = OthersFirst }) = object [ ("type", String "ListsFirst") ]
-  toJSON (NoList _) = object [ ("type", String "NoList") ]
-  toJSON (FlowSocialListWithLists { fslw_lists = ids }) = object [ ("type", String "SelectedLists")
-                                                                 , ("value", Array $ V.fromList $ (map (\(NodeId id) -> Number $ Scientific.scientific (Prelude.toInteger id) 1) ids)) ]
+  toJSON (FlowSocialListWithPriority { fslw_priority = OthersFirst }) = object [ ("type", String "OthersFirst") ]
+  toJSON (NoList v) = object [ ("type", String "NoList"), ("makeList", toJSON v) ]
+  toJSON (FlowSocialListWithLists { fslw_lists = ids }) =
+    object [ ("type", String "SelectedLists")
+           , ("value", Array $ V.fromList (map (\(NodeId id) -> toJSON id) ids)) ]
+
+instance Arbitrary FlowSocialListWith where
+  arbitrary = oneof [
+      FlowSocialListWithPriority <$> arbitrary
+    , FlowSocialListWithLists <$> arbitrary
+    , NoList <$> arbitrary
+    ]
+
 instance ToSchema FlowSocialListWith where
   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
 instance FromHttpApiData FlowSocialListWith
@@ -87,10 +98,13 @@ instance ToHttpApiData   FlowSocialListWith where
     toUrlPiece (FlowSocialListWithLists _)  = panic "[G.C.T.L.Social] TODO ToHttpApiData FlowSocialListWith"
 
 data FlowSocialListPriority = MySelfFirst | OthersFirst
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, Enum, Bounded)
 instance ToSchema FlowSocialListPriority where
   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
 
+instance Arbitrary FlowSocialListPriority where
+  arbitrary = arbitraryBoundedEnum
+
 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst