Fix compilation errors due to switch to GHC 9.4.7

cabal.project.freeze

@@ -1704,15 +1704,15 @@ constraints: any.AC-Angle ==1.0,
              any.monoid-transformer ==0.0.4,
              any.monoidal-containers ==0.6.4.0,
              any.more-containers ==0.2.2.2,
-             any.morpheus-graphql ==0.27.3,
-             any.morpheus-graphql-app ==0.27.3,
-             any.morpheus-graphql-client ==0.27.3,
-             any.morpheus-graphql-code-gen ==0.27.3,
-             any.morpheus-graphql-code-gen-utils ==0.27.3,
-             any.morpheus-graphql-core ==0.27.3,
-             any.morpheus-graphql-server ==0.27.3,
-             any.morpheus-graphql-subscriptions ==0.27.3,
-             any.morpheus-graphql-tests ==0.27.3,
+             any.morpheus-graphql ==0.24.3,
+             any.morpheus-graphql-app ==0.24.3,
+             any.morpheus-graphql-client ==0.24.3,
+             any.morpheus-graphql-code-gen ==0.24.3,
+             any.morpheus-graphql-code-gen-utils ==0.24.3,
+             any.morpheus-graphql-core ==0.24.3,
+             any.morpheus-graphql-server ==0.24.3,
+             any.morpheus-graphql-subscriptions ==0.24.3,
+             any.morpheus-graphql-tests ==0.24.3,
              any.moss ==0.2.0.1,
              any.mountpoints ==1.0.2,
              any.mpi-hs ==0.7.2.0,

gargantext.cabal

@@ -45,6 +45,10 @@ flag test-crypto
   default: False
   manual: True
 
+flag disable-db-obfuscation-executable
+  default: False
+  manual: True
+
 library
   exposed-modules:
       Gargantext
@@ -165,6 +169,7 @@ library
       Gargantext.Utils.Jobs.Settings
       Gargantext.Utils.Jobs.State
       Gargantext.Utils.SpacyNLP
+      Gargantext.Utils.SpacyNLP.Types
       Gargantext.Utils.Tuple
       Gargantext.Utils.Zip
   other-modules:
@@ -491,10 +496,11 @@ library
     , matrix ^>= 0.3.6.1
     , monad-control ^>= 1.0.3.1
     , monad-logger ^>= 0.3.36
-    , morpheus-graphql ^>= 0.17.0
-    , morpheus-graphql-app ^>= 0.17.0
-    , morpheus-graphql-core ^>= 0.17.0
-    , morpheus-graphql-subscriptions ^>= 0.17.0
+    , morpheus-graphql >= 0.17.0 && < 0.25
+    , morpheus-graphql-app >= 0.17.0 && < 0.25
+    , morpheus-graphql-core >= 0.17.0 && < 0.25
+    , morpheus-graphql-server >= 0.17.0 && < 0.25
+    , morpheus-graphql-subscriptions >= 0.17.0 && < 0.25
     , mtl ^>= 2.2.2
     , natural-transformation ^>= 0.4
     , network-uri ^>= 2.6.4.1
@@ -547,6 +553,7 @@ library
     , servant-xml-conduit >= 0.1.0.4
     , simple-reflect ^>= 0.3.3
     , singletons ^>= 2.7
+    , singletons-th >= 3.1
     , split ^>= 0.2.3.4
     , stemmer ^>= 0.5.2
     , stm ^>= 2.5.0.1
@@ -714,15 +721,18 @@ executable gargantext-db-obfuscation
       RecordWildCards
       StrictData
   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -Wmissing-signatures
-  build-depends:
-      base
-    , extra
-    , gargantext
-    , gargantext-prelude
-    , optparse-simple
-    , postgresql-simple ^>= 0.6.4
-    , text
-  default-language: Haskell2010
+  if flag(disable-db-obfuscation-executable)
+    buildable: False
+  else
+    build-depends:
+        base
+      , extra
+      , gargantext
+      , gargantext-prelude
+      , optparse-simple
+      , postgresql-simple ^>= 0.6.4
+      , text
+    default-language: Haskell2010
 
 executable gargantext-import
   main-is: Main.hs

src/Gargantext/API/Admin/Auth/Types.hs

@@ -52,16 +52,11 @@ data AuthenticatedUser = AuthenticatedUser
   , _auth_user_id :: UserId
   } deriving (Generic)
 
-$(deriveJSON (JSON.defaultOptions { JSON.fieldLabelModifier = tail . dropWhile ((/=) '_') . tail }) ''AuthenticatedUser)
-
 makeLenses ''AuthenticatedUser
 
 instance ToSchema AuthenticatedUser where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
 
-instance ToJWT AuthenticatedUser
-instance FromJWT AuthenticatedUser
-
 data AuthenticationError
   = LoginFailed NodeId UserId Jose.Error
   | InvalidUsernameOrPassword
@@ -71,7 +66,6 @@ data AuthenticationError
 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 
 -- | Instances
-$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 instance ToSchema AuthRequest where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
 
@@ -81,7 +75,6 @@ instance Arbitrary AuthRequest where
                        , p <- arbitraryPassword
                        ]
 
-$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 instance ToSchema AuthResponse where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
 instance Arbitrary AuthResponse where
@@ -101,20 +94,43 @@ type Password = Text
 
 data ForgotPasswordRequest = ForgotPasswordRequest { _fpReq_email :: Email }
   deriving (Generic )
-$(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
 instance ToSchema ForgotPasswordRequest where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpReq_")
 
 data ForgotPasswordResponse = ForgotPasswordResponse { _fpRes_status :: Text }
   deriving (Generic )
-$(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
 instance ToSchema ForgotPasswordResponse where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpRes_")
 
 data ForgotPasswordGet = ForgotPasswordGet {_fpGet_password :: Password}
   deriving (Generic )
-$(deriveJSON (unPrefix "_fpGet_") ''ForgotPasswordGet)
 instance ToSchema ForgotPasswordGet where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpGet_")
 
+--
+-- Lenses
+--
+
+makeLenses ''AuthValid
+>>>>>>> b7657056 (Fix compilation errors due to switch to GHC 9.4.7)
 makeLenses ''AuthResponse
+
+--
+-- JSON instances
+--
+
+$(deriveJSON (JSON.defaultOptions { JSON.fieldLabelModifier = tail . dropWhile ((/=) '_') . tail }) ''AuthenticatedUser)
+$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
+$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
+$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
+$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
+$(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
+$(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
+$(deriveJSON (unPrefix "_fpGet_") ''ForgotPasswordGet)
+
+--
+-- JWT instances
+--
+
+instance ToJWT AuthenticatedUser
+instance FromJWT AuthenticatedUser

src/Gargantext/API/Admin/Settings.hs

@@ -24,7 +24,8 @@ import Control.Lens
 import Control.Monad.Logger (LogLevel(..))
 import Control.Monad.Reader
 import Data.ByteString.Lazy qualified as L
-import Data.Pool (Pool, createPool)
+import Data.Pool (Pool)
+import qualified Data.Pool as Pool
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
@@ -217,7 +218,7 @@ newEnv logger port file = do
     }
 
 newPool :: ConnectInfo -> IO (Pool Connection)
-newPool param = createPool (connect param) close 1 (60*60) 8
+newPool param = Pool.newPool $ Pool.setNumStripes (Just 1) $ Pool.defaultPoolConfig (connect param) close (60*60) 8
 
 {-
 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()

src/Gargantext/API/Count.hs

@@ -104,18 +104,12 @@ messages =  toMessage $ [ (400, ["Ill formed query             "])
 instance Arbitrary Message where
     arbitrary = elements messages
 
-instance FromJSON Message
-instance ToJSON   Message
-
 instance ToSchema Message
 -----------------------------------------------------------------------
 data Counts = Counts { results :: [Either Message Count]
                      } deriving (Eq, Show, Generic)
 
 
-instance FromJSON Counts
-instance ToJSON   Counts
-
 instance Arbitrary Counts where
     arbitrary = elements [Counts [ Right (Count Pubmed (Just 20 ))
                                  , Right (Count IsTex  (Just 150))
@@ -131,8 +125,6 @@ data Count = Count { count_name    :: Scraper
                    }
                    deriving (Eq, Show, Generic)
 
-$(deriveJSON (unPrefix "count_") ''Count)
-
 instance ToSchema Count where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
 --instance Arbitrary Count where
@@ -141,3 +133,16 @@ instance ToSchema Count where
 -----------------------------------------------------------------------
 count :: Monad m => Query -> m Counts
 count _ = undefined
+
+--
+-- JSON instances
+--
+
+instance FromJSON Message
+instance ToJSON   Message
+
+$(deriveJSON (unPrefix "count_") ''Count)
+
+instance FromJSON Counts
+instance ToJSON   Counts
+

src/Gargantext/API/Errors/Types.hs

@@ -671,8 +671,8 @@ genFrontendErr be = do
     EC_404__tree_empty_root
       -> pure $ mkFrontendErr' txt $ FE_tree_empty_root
     EC_500__tree_too_many_roots
-      -> do nodes <- arbitrary
-            pure $ mkFrontendErr' txt $ FE_tree_too_many_roots nodes
+      -> do nodes <- getNonEmpty <$> arbitrary
+            pure $ mkFrontendErr' txt $ FE_tree_too_many_roots (NE.fromList nodes)
 
     -- job errors
     EC_500__job_invalid_id_type

src/Gargantext/API/GraphQL.hs

@@ -22,7 +22,7 @@ import Data.ByteString.Lazy.Char8 ( ByteString )
 import Data.Morpheus ( App, deriveApp )
 import Data.Morpheus.Server ( httpPlayground )
 import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
-import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined(..) )
+import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
 import Data.Proxy
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
@@ -111,7 +111,7 @@ rootResolver
   -> AccessPolicyManager
   -> RootResolver (GargM env BackendInternalError) e Query Mutation Undefined
 rootResolver authenticatedUser policyManager =
-  RootResolver
+  defaultRootResolver
     { queryResolver = Query { annuaire_contacts   = GQLA.resolveAnnuaireContacts
                             , context_ngrams      = GQLCTX.resolveContextNgrams
                             , contexts            = GQLCTX.resolveNodeContext
@@ -133,7 +133,7 @@ rootResolver authenticatedUser policyManager =
                                   , update_user_epo_api_token = GQLUser.updateUserEPOAPIToken
                                   , delete_team_membership = GQLTeam.deleteTeamMembership
                                   , update_node_context_category = GQLCTX.updateNodeContextCategory }
-    , subscriptionResolver = Undefined }
+    }
 
 -- | Main GraphQL "app".
 app

src/Gargantext/API/GraphQL/Node.hs

@@ -15,7 +15,7 @@ Portability : POSIX
 module Gargantext.API.GraphQL.Node where
 
 import Data.Aeson
-import Data.HashMap.Strict qualified as HashMap
+import Data.Aeson.KeyMap qualified as KM
 import Data.Morpheus.Types ( GQLType )
 import Data.Text qualified as T
 import Gargantext.API.Admin.Auth.Types
@@ -126,7 +126,7 @@ toCorpus N.Node { .. } = Corpus { id = NN.unNodeId _node_id
 
 pubmedAPIKeyFromValue :: Value -> Maybe PUBMED.APIKey
 pubmedAPIKeyFromValue (Object kv) =
-  case HashMap.lookup "pubmed_api_key" kv of
+  case KM.lookup "pubmed_api_key" kv of
     Nothing -> Nothing
     Just v  -> case fromJSON v of
       Error _    -> Nothing

src/Gargantext/API/GraphQL/Utils.hs

@@ -8,6 +8,8 @@ Stability   : experimental
 Portability : POSIX
 -}
 
+{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(adn) GraphQL will need updating.
+
 module Gargantext.API.GraphQL.Utils where
 
 import Control.Lens.Getter (view)

src/Gargantext/API/Ngrams.hs

@@ -120,7 +120,7 @@ import Gargantext.Database.Query.Table.Node (getNode)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select
 import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
-import Gargantext.Prelude hiding (log, to, toLower, (%))
+import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
 import Gargantext.Prelude.Clock (hasTime, getTime)
 import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
 import GHC.Conc (readTVar, writeTVar)

src/Gargantext/API/Ngrams/Tools.hs

@@ -9,7 +9,8 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies  #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Gargantext.API.Ngrams.Tools
   where

src/Gargantext/API/Ngrams/Types.hs

@@ -84,8 +84,6 @@ instance ToParamSchema TabType
 instance ToJSON        TabType
 instance FromJSON      TabType
 instance ToSchema      TabType
-instance Arbitrary     TabType where
-  arbitrary = elements [minBound .. maxBound]
 instance FromJSONKey TabType where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 instance ToJSONKey TabType where
@@ -161,14 +159,11 @@ deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 makeLenses ''NgramsRepoElement
 instance ToSchema NgramsRepoElement where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
-instance Serialise NgramsRepoElement
 instance FromField NgramsRepoElement where
   fromField = fromJSONField
 instance ToField NgramsRepoElement where
   toField = toJSONField
 
-instance Serialise (MSet NgramsTerm)
-
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
                    , _ne_size        :: Int
@@ -197,9 +192,6 @@ newNgramsElement mayList ngrams =
 
 instance ToSchema NgramsElement where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
-instance Arbitrary NgramsElement where
-  arbitrary = elements [newNgramsElement Nothing "sport"]
-
 
 ------------------------------------------------------------------------
 newtype NgramsTable = NgramsTable [NgramsElement]
@@ -257,9 +249,6 @@ mockTable = NgramsTable
   where
     rp n = Just $ RootParent n n
 
-instance Arbitrary NgramsTable where
-  arbitrary = pure mockTable
-
 instance ToSchema NgramsTable
 
 ------------------------------------------------------------------------
@@ -283,10 +272,6 @@ instance ToParamSchema OrderBy
 instance FromJSON  OrderBy
 instance ToJSON    OrderBy
 instance ToSchema  OrderBy
-instance Arbitrary OrderBy
-  where
-    arbitrary = elements [minBound..maxBound]
-
 
 -- | A query on a 'NgramsTable'.
 data NgramsSearchQuery = NgramsSearchQuery
@@ -367,8 +352,6 @@ instance ToSchema a => ToSchema (PatchSet a)
 
 type AddRem = Replace (Maybe ())
 
-instance Serialise AddRem
-
 remPatch, addPatch :: AddRem
 remPatch = replace (Just ()) Nothing
 addPatch = replace Nothing (Just ())
@@ -388,9 +371,6 @@ unPatchMSet (PatchMSet a) = a
 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 
-instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
-instance (Serialise a, Ord a) => Serialise (PatchMSet a)
-
 -- TODO this breaks module abstraction
 makePrisms ''PM.PatchMap
 
@@ -419,19 +399,12 @@ instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 
-instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
-  arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
-
 instance ToSchema a => ToSchema (PatchMSet a) where
   -- TODO
   declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
 
 type instance Patched (PatchMSet a) = MSet a
 
-instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
-  arbitrary = uncurry replace <$> arbitrary
-    -- If they happen to be equal then the patch is Keep.
-
 instance ToSchema a => ToSchema (Replace a) where
   declareNamedSchema (_ :: Proxy (Replace a)) = do
     -- TODO Keep constructor is not supported here.
@@ -475,19 +448,11 @@ instance ToSchema NgramsPatch where
                 , ("old",      nreSch)
                 , ("new",      nreSch)
                 ]
-instance Arbitrary NgramsPatch where
-  arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
-                        , (1, NgramsReplace <$> arbitrary <*> arbitrary)
-                        ]
-instance Serialise NgramsPatch
 instance FromField NgramsPatch where
   fromField = fromJSONField
 instance ToField NgramsPatch where
   toField = toJSONField
 
-instance Serialise (Replace ListType)
-
-instance Serialise ListType
 
 type NgramsPatchIso =
   MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
@@ -555,9 +520,6 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
 mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
 
-instance Serialise NgramsTablePatch
-instance Serialise (PatchMap NgramsTerm NgramsPatch)
-
 instance FromField NgramsTablePatch
   where
     fromField = fromJSONField
@@ -690,9 +652,6 @@ instance Action NgramsTablePatch (Maybe NgramsTableMap) where
     fmap (execState (reParentNgramsTablePatch p)) .
     act (p ^. _NgramsTablePatch)
 
-instance Arbitrary NgramsTablePatch where
-  arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
-
 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
@@ -709,8 +668,6 @@ deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
   declareNamedSchema = wellNamedSchema "_v_"
-instance Arbitrary a => Arbitrary (Versioned a) where
-  arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 ------------------------------------------------------------------------
 type Count = Int
 
@@ -724,8 +681,6 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 makeLenses ''VersionedWithCount
 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
   declareNamedSchema = wellNamedSchema "_vc_"
-instance Arbitrary a => Arbitrary (VersionedWithCount a) where
-  arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
 
 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
@@ -749,8 +704,6 @@ instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
   toJSON     = genericToJSON     $ unPrefix "_r_"
   toEncoding = genericToEncoding $ unPrefix "_r_"
 
-instance (Serialise s, Serialise p) => Serialise (Repo s p)
-
 makeLenses ''Repo
 
 initRepo :: Monoid s => Repo s p
@@ -771,11 +724,6 @@ type RepoCmdM   env err m =
 
 
 -- Instances
-instance Arbitrary NgramsRepoElement where
-  arbitrary = elements $ map ngramsElementToRepo ns
-    where
-      NgramsTable ns = mockTable
-
 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
   where
     parseUrlPiece x = maybeToEither x (decode $ cs x)
@@ -814,3 +762,51 @@ instance ToSchema UpdateTableNgramsCharts where
 
 ------------------------------------------------------------------------
 type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
+
+--
+-- Serialise instances
+--
+
+instance Serialise ListType
+instance Serialise NgramsRepoElement
+instance Serialise NgramsTablePatch
+instance Serialise (PatchMap NgramsTerm NgramsPatch)
+instance Serialise (MSet NgramsTerm)
+instance Serialise AddRem
+instance Serialise NgramsPatch
+instance Serialise (Replace ListType)
+instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
+instance (Serialise a, Ord a) => Serialise (PatchMSet a)
+instance (Serialise s, Serialise p) => Serialise (Repo s p)
+
+--
+-- Arbitrary instances
+--
+instance Arbitrary     TabType where
+  arbitrary = elements [minBound .. maxBound]
+instance Arbitrary NgramsElement where
+  arbitrary = elements [newNgramsElement Nothing "sport"]
+instance Arbitrary NgramsTable where
+  arbitrary = pure mockTable
+instance Arbitrary OrderBy
+  where
+    arbitrary = elements [minBound..maxBound]
+instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
+  arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
+instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
+  arbitrary = uncurry replace <$> arbitrary
+    -- If they happen to be equal then the patch is Keep.
+instance Arbitrary NgramsPatch where
+  arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
+                        , (1, NgramsReplace <$> arbitrary <*> arbitrary)
+                        ]
+instance Arbitrary NgramsTablePatch where
+  arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
+instance Arbitrary a => Arbitrary (Versioned a) where
+  arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
+instance Arbitrary a => Arbitrary (VersionedWithCount a) where
+  arbitrary = VersionedWithCount 1 1 <$> arbitrary -- TODO 1 is constant so far
+instance Arbitrary NgramsRepoElement where
+  arbitrary = elements $ map ngramsElementToRepo ns
+    where
+      NgramsTable ns = mockTable

src/Gargantext/API/Node.hs

@@ -189,62 +189,6 @@ nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uI
     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
     nodeNodeAPI' = getNodeWith nId p
 
-------------------------------------------------------------------------
--- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: forall proxy a.
-       ( HyperdataC a, Show a
-       ) => proxy a
-         -> AuthenticatedUser
-         -> NodeId
-         -> ServerT (NodeAPI a) (GargM Env BackendInternalError)
-nodeAPI p authenticatedUser targetNode =
-  withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
-  where
-
-    userRootId = RootId $ authenticatedUser ^. auth_node_id
-
-    nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
-    nodeAPI' =  withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
-           :<|> rename                                targetNode
-           :<|> postNode            authenticatedUser targetNode
-           :<|> postNodeAsyncAPI    authenticatedUser targetNode
-           :<|> FrameCalcUpload.api authenticatedUser targetNode
-           :<|> putNode                               targetNode
-           :<|> Update.api                            targetNode
-           :<|> Action.deleteNode   userRootId        targetNode
-           :<|> getChildren                           targetNode p
-
-           -- TODO gather it
-           :<|> tableApi                              targetNode
-           :<|> apiNgramsTableCorpus                  targetNode
-
-           :<|> catApi                                targetNode
-           :<|> scoreApi                              targetNode
-           :<|> Search.api                            targetNode
-           :<|> Share.api           userRootId        targetNode
-           -- Pairing Tools
-           :<|> pairWith                              targetNode
-           :<|> pairs                                 targetNode
-           :<|> getPair                               targetNode
-
-           -- VIZ
-           :<|> scatterApi                            targetNode
-           :<|> chartApi                              targetNode
-           :<|> pieApi                                targetNode
-           :<|> treeApi                               targetNode
-           :<|> phyloAPI                              targetNode
-           :<|> moveNode           userRootId         targetNode
-           -- :<|> nodeAddAPI id'
-           -- :<|> postUpload id'
-           :<|> Share.unPublish                       targetNode
-
-           :<|> fileApi                               targetNode
-           :<|> fileAsyncApi       authenticatedUser  targetNode
-
-           :<|> DFWN.api           authenticatedUser  targetNode
-           :<|> DocumentUpload.api                    targetNode
-
-
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
@@ -374,5 +318,59 @@ instance ToSchema  RenameNode
 instance Arbitrary RenameNode where
   arbitrary = elements [RenameNode "test"]
 
+------------------------------------------------------------------------
+-- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
+nodeAPI :: forall proxy a.
+       ( HyperdataC a, Show a, MimeUnrender JSON a
+       ) => proxy a
+         -> AuthenticatedUser
+         -> NodeId
+         -> ServerT (NodeAPI a) (GargM Env BackendInternalError)
+nodeAPI p authenticatedUser targetNode =
+  withAccess (Proxy :: Proxy (NodeAPI a)) Proxy authenticatedUser (PathNode targetNode) nodeAPI'
+  where
+
+    userRootId = RootId $ authenticatedUser ^. auth_node_id
+
+    nodeAPI' :: ServerT (NodeAPI a) (GargM Env BackendInternalError)
+    nodeAPI' =  withPolicy authenticatedUser (nodeChecks targetNode) (getNodeWith targetNode p)
+           :<|> rename                                targetNode
+           :<|> postNode            authenticatedUser targetNode
+           :<|> postNodeAsyncAPI    authenticatedUser targetNode
+           :<|> FrameCalcUpload.api authenticatedUser targetNode
+           :<|> putNode                               targetNode
+           :<|> Update.api                            targetNode
+           :<|> Action.deleteNode   userRootId        targetNode
+           :<|> getChildren                           targetNode p
+
+           -- TODO gather it
+           :<|> tableApi                              targetNode
+           :<|> apiNgramsTableCorpus                  targetNode
+
+           :<|> catApi                                targetNode
+           :<|> scoreApi                              targetNode
+           :<|> Search.api                            targetNode
+           :<|> Share.api           userRootId        targetNode
+           -- Pairing Tools
+           :<|> pairWith                              targetNode
+           :<|> pairs                                 targetNode
+           :<|> getPair                               targetNode
+
+           -- VIZ
+           :<|> scatterApi                            targetNode
+           :<|> chartApi                              targetNode
+           :<|> pieApi                                targetNode
+           :<|> treeApi                               targetNode
+           :<|> phyloAPI                              targetNode
+           :<|> moveNode           userRootId         targetNode
+           -- :<|> nodeAddAPI id'
+           -- :<|> postUpload id'
+           :<|> Share.unPublish                       targetNode
+
+           :<|> fileApi                               targetNode
+           :<|> fileAsyncApi       authenticatedUser  targetNode
+
+           :<|> DFWN.api           authenticatedUser  targetNode
+           :<|> DocumentUpload.api                    targetNode
+
 
--------------------------------------------------------------

src/Gargantext/API/Node/Document/Export/Types.hs

@@ -94,6 +94,6 @@ type API = Summary "Document Export"
                :<|> "csv"
                :> Get '[PlainText] (Headers '[Servant.Header "Content-Disposition" Text] Text)) -- [Document])
 
-$(deriveJSON (unPrefix "_de_") ''DocumentExport)
-$(deriveJSON (unPrefix "_d_") ''Document)
 $(deriveJSON (unPrefix "_ng_") ''Ngrams)
+$(deriveJSON (unPrefix "_d_") ''Document)
+$(deriveJSON (unPrefix "_de_") ''DocumentExport)

src/Gargantext/Core/NodeStory.hs

@@ -701,7 +701,7 @@ clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHi
 currentVersion :: (HasNodeStory env err m) => ListId -> m Version
 currentVersion listId = do
   pool <- view connPool
-  nls <- withResource pool $ \c -> liftBase $ getNodeStory c listId
+  nls <- liftBase $ withResource pool $ \c -> liftBase $ getNodeStory c listId
   pure $ nls ^. unNodeStory . at listId . _Just . a_version
 
 
@@ -711,7 +711,7 @@ currentVersion listId = do
 fixNodeStoryVersions :: (HasNodeStory env err m) => m ()
 fixNodeStoryVersions = do
   pool <- view connPool
-  _ <- withResource pool $ \c -> liftBase $ PGS.withTransaction c $ do
+  _ <- liftBase $ withResource pool $ \c -> liftBase $ PGS.withTransaction c $ do
     nIds <- runPGSQuery c [sql| SELECT id FROM nodes WHERE ? |] (PGS.Only True) :: IO [PGS.Only Int64]
     -- printDebug "[fixNodeStoryVersions] nIds" nIds
     mapM_ (\(PGS.Only nId) -> do

src/Gargantext/Core/Text/Corpus/Parsers/Date.hs

@@ -24,7 +24,7 @@ module Gargantext.Core.Text.Corpus.Parsers.Date
 
 import Data.Aeson (toJSON, Value)
 import Data.Aeson qualified as Json
-import Data.HashMap.Strict as HM hiding (map)
+import Data.Aeson.KeyMap as KM hiding (map)
 import Data.HashSet qualified as HashSet
 import Data.List qualified as List
 import Data.Text (unpack, splitOn, replace)
@@ -184,7 +184,7 @@ getTimeValue rt = case head rt of
 
 extractValue :: Maybe Value -> Maybe Text
 extractValue (Just (Json.Object object)) =
-  case HM.lookup "value" object of
+  case KM.lookup "value" object of
     Just (Json.String date) -> Just date
     _                  -> Nothing
 extractValue _ = Nothing

src/Gargantext/Core/Text/Terms/Eleve.hs

@@ -34,10 +34,11 @@ Notes for current implementation:
 
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
-{-# LANGUAGE ConstraintKinds   #-}
-{-# LANGUAGE StandaloneDeriving   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module Gargantext.Core.Text.Terms.Eleve where
 

src/Gargantext/Core/Text/Terms/Mono/Token/En.hs

@@ -143,11 +143,11 @@ whitespace :: Tokenizer
 whitespace xs = E [Right w | w <- T.words xs ]
 
 instance Monad (EitherList a) where
-    return x = E [Right x]
+    return = pure
     E xs >>= f = E $ concatMap (either (return . Left) (unE . f)) xs
 
 instance Applicative (EitherList a) where
-    pure = pure
+    pure x = E [Right x]
     f <*> x = f `ap` x
 
 instance Functor (EitherList a) where

src/Gargantext/Core/Types/Phylo.hs

@@ -216,43 +216,6 @@ data ObjectData =
   | Layer        !GvId !GraphDataData  !LayerData
   deriving (Show, Eq, Generic)
 
-instance ToJSON ObjectData where
-  toJSON = \case
-    GroupToNode gvid commonData nodeTypeData
-      -> mkObject gvid (Left commonData) nodeTypeData
-    BranchToNode gvid commonData nodeTypeData
-      -> mkObject gvid (Left commonData) nodeTypeData
-    PeriodToNode gvid commonData nodeTypeData
-      -> mkObject gvid (Left commonData) nodeTypeData
-    Layer gvid graphData nodeTypeData
-      -> mkObject gvid (Right graphData) nodeTypeData
-
-instance FromJSON ObjectData where
-  parseJSON = withObject "ObjectData" $ \o -> do
-    _gvid        <- o .: "_gvid"
-    -- try to parse the graph data first. If we succeed, then we are dealing with
-    -- the 'Layer', otherwise we the rest, but for the rest we can avoid re-parsing
-    -- the 'NodeCommonData' every time.
-    case parseMaybe @_ @GraphDataData parseJSON (Object o) of
-      Nothing
-        -> do commonData <- parseJSON (Object o)
-              ((GroupToNode  <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
-               (BranchToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
-               (PeriodToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)))
-      Just gd
-        -> Layer <$> pure _gvid <*> pure gd <*> parseJSON (Object o)
-
-
-mkObject :: ToJSON a => GvId -> Either NodeCommonData GraphDataData -> a -> Value
-mkObject gvid commonData objectTypeData =
-  let commonDataJSON   = either toJSON toJSON commonData
-      objectTypeDataJSON = toJSON objectTypeData
-      header           = object $ [ "_gvid"    .= toJSON gvid ]
-  in case (commonDataJSON, objectTypeDataJSON, header) of
-    (Object hdr, Object cdJSON, Object etDataJSON)
-      -> Object $ hdr <> cdJSON <> etDataJSON
-    _ -> panicTrace "[Gargantext.Core.Types.Phylo.mkObject] impossible: commonData, header or objectTypeDataJSON didn't convert back to JSON Object."
-
 data GroupToNodeData
   = GroupToNodeData
     { _gtn_bId        :: Text
@@ -474,17 +437,23 @@ data BranchToGroupData
     , _btg_style :: Maybe Text
     } deriving (Show, Eq, Generic)
 
--- | Lenses
-makeLenses ''Phylo
-makeLenses ''PhyloPeriod
-makeLenses ''PhyloLevel
-makeLenses ''PhyloGroup
-
 -- | JSON instances
-$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
-$(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
-$(deriveJSON (unPrefix "_phylo_Level"  ) ''PhyloLevel  )
-$(deriveJSON (unPrefix "_phylo_Group"  ) ''PhyloGroup  )
+instance ToJSON GvId where
+  toJSON GvId{..} = toJSON _GvId
+instance FromJSON GvId where
+  parseJSON v = GvId <$> parseJSON v
+
+-- /NOTE/ We need to define /after/ the JSON istance for 'GvId' due to GHC stage limitation.
+mkObject :: ToJSON a => GvId -> Either NodeCommonData GraphDataData -> a -> Value
+mkObject gvid commonData objectTypeData =
+  let commonDataJSON   = either toJSON toJSON commonData
+      objectTypeDataJSON = toJSON objectTypeData
+      header           = object $ [ "_gvid"    .= toJSON gvid ]
+  in case (commonDataJSON, objectTypeDataJSON, header) of
+    (Object hdr, Object cdJSON, Object etDataJSON)
+      -> Object $ hdr <> cdJSON <> etDataJSON
+    _ -> panicTrace "[Gargantext.Core.Types.Phylo.mkObject] impossible: commonData, header or objectTypeDataJSON didn't convert back to JSON Object."
+
 
 instance ToJSON GraphData where
   toJSON = mkGraphData
@@ -512,11 +481,6 @@ instance FromJSON GraphData where
     _gd_data          <- parseJSON (Object o)
     pure GraphData{..}
 
-instance ToJSON GvId where
-  toJSON GvId{..} = toJSON _GvId
-instance FromJSON GvId where
-  parseJSON v = GvId <$> parseJSON v
-
 instance ToJSON EdgeData where
   toJSON = \case
     GroupToAncestor gvid commonData edgeTypeData
@@ -608,6 +572,38 @@ instance FromJSON BranchToGroupData where
     _btg_style     <- o .:? "style"
     pure BranchToGroupData{..}
 
+instance ToJSON ObjectData where
+  toJSON = \case
+    GroupToNode gvid commonData nodeTypeData
+      -> mkObject gvid (Left commonData) nodeTypeData
+    BranchToNode gvid commonData nodeTypeData
+      -> mkObject gvid (Left commonData) nodeTypeData
+    PeriodToNode gvid commonData nodeTypeData
+      -> mkObject gvid (Left commonData) nodeTypeData
+    Layer gvid graphData nodeTypeData
+      -> mkObject gvid (Right graphData) nodeTypeData
+
+instance FromJSON ObjectData where
+  parseJSON = withObject "ObjectData" $ \o -> do
+    _gvid        <- o .: "_gvid"
+    -- try to parse the graph data first. If we succeed, then we are dealing with
+    -- the 'Layer', otherwise we the rest, but for the rest we can avoid re-parsing
+    -- the 'NodeCommonData' every time.
+    case parseMaybe @_ @GraphDataData parseJSON (Object o) of
+      Nothing
+        -> do commonData <- parseJSON (Object o)
+              ((GroupToNode  <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
+               (BranchToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)) <|>
+               (PeriodToNode <$> pure _gvid <*> pure commonData <*> parseJSON (Object o)))
+      Just gd
+        -> Layer <$> pure _gvid <*> pure gd <*> parseJSON (Object o)
+
+
+
+$(deriveJSON (unPrefix "_phylo_Group"  ) ''PhyloGroup  )
+$(deriveJSON (unPrefix "_phylo_Level"  ) ''PhyloLevel  )
+$(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
+$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
 
 -- | ToSchema instances
 instance ToSchema Phylo where
@@ -637,7 +633,9 @@ instance ToSchema GraphDataData where
 instance ToSchema GraphData where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gd_")
 
--- | Arbitrary instances
+--
+-- Arbitrary instances
+--
 instance Arbitrary LayerData where
   arbitrary = LayerData <$> arbitrary
 instance Arbitrary NodeCommonData where
@@ -723,3 +721,13 @@ instance Arbitrary GraphDataData where
                             <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
                             <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
                             <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+--
+-- Lenses
+--
+
+makeLenses ''Phylo
+makeLenses ''PhyloPeriod
+makeLenses ''PhyloLevel
+makeLenses ''PhyloGroup
+

src/Gargantext/Core/Viz/LegacyPhylo.hs

@@ -475,38 +475,38 @@ makeLenses ''PhyloEdge
 ------------------------
 
 
-$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
+$(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
+$(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_foundations"  ) ''PhyloFoundations  )
 $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
-$(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
-$(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
 $(deriveJSON (unPrefix "_phyloFis_"    ) ''PhyloFis    )
 --
-$(deriveJSON (unPrefix "_software_"    ) ''Software    )
-$(deriveJSON (unPrefix "_phyloParam_"  ) ''PhyloParam  )
+$(deriveJSON (unPrefix "_lb_" )      ''LBParams      )
+$(deriveJSON (unPrefix "_sb_" )      ''SBParams      )
+--
+$(deriveJSON (unPrefix "_fis_" )     ''FisParams     )
+$(deriveJSON (unPrefix "_hamming_" ) ''HammingParams )
+$(deriveJSON (unPrefix "_wlj_" )     ''WLJParams     )
 --
 $(deriveJSON defaultOptions ''Filter    )
 $(deriveJSON defaultOptions ''Metric    )
-$(deriveJSON defaultOptions ''Cluster   )
 $(deriveJSON defaultOptions ''Proximity )
---
-$(deriveJSON (unPrefix "_fis_" )     ''FisParams     )
-$(deriveJSON (unPrefix "_hamming_" ) ''HammingParams )
 $(deriveJSON (unPrefix "_louvain_" ) ''LouvainParams )
 $(deriveJSON (unPrefix "_rc_" )      ''RCParams      )
-$(deriveJSON (unPrefix "_wlj_" )     ''WLJParams     )
+$(deriveJSON defaultOptions ''Cluster   )
+$(deriveJSON (unPrefix "_q_" )  ''PhyloQueryBuild  )
 --
-$(deriveJSON (unPrefix "_lb_" )      ''LBParams      )
-$(deriveJSON (unPrefix "_sb_" )      ''SBParams      )
+$(deriveJSON (unPrefix "_software_"    ) ''Software    )
+$(deriveJSON (unPrefix "_phyloParam_"  ) ''PhyloParam  )
+$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
 --
-$(deriveJSON (unPrefix "_q_" )  ''PhyloQueryBuild  )
-$(deriveJSON (unPrefix "_pv_" ) ''PhyloView   )
 $(deriveJSON (unPrefix "_pb_" ) ''PhyloBranch )
-$(deriveJSON (unPrefix "_pe_" ) ''PhyloEdge   )
-$(deriveJSON (unPrefix "_pn_" ) ''PhyloNode   )
-
 $(deriveJSON defaultOptions ''Filiation )
+$(deriveJSON (unPrefix "_pn_" ) ''PhyloNode   )
 $(deriveJSON defaultOptions ''EdgeType  )
+$(deriveJSON (unPrefix "_pe_" ) ''PhyloEdge   )
+$(deriveJSON (unPrefix "_pv_" ) ''PhyloView   )
+
 
 ---------------------------
 -- | Swagger instances | --

src/Gargantext/Core/Viz/Phylo.hs

@@ -625,9 +625,6 @@ makeLenses ''PhyloBranch
 -- | JSON instances | --
 ------------------------
 
-instance FromJSON Phylo
-instance ToJSON Phylo
-
 instance FromJSON PhyloSources
 instance ToJSON PhyloSources
 
@@ -651,6 +648,9 @@ instance ToJSON PhyloGroup
 
 $(deriveJSON (unPrefix "_foundations_"  ) ''PhyloFoundations)
 
+instance FromJSON Phylo
+instance ToJSON Phylo
+
 -- NFData instances
 
 instance NFData CorpusParser
@@ -677,3 +677,4 @@ instance NFData Order
 instance NFData Sort
 instance NFData Tagger
 instance NFData PhyloLabel
+

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -114,7 +114,7 @@ corpusIdtoDocuments timeUnit corpusId = do
   docs <- selectDocNodes corpusId
   lId  <- defaultList corpusId
   termList <- getTermList lId MapTerm NgramsTerms
-  corpus_node <- getNodeWith corpusId (Proxy @ HyperdataCorpus)
+  corpus_node <- getNodeWith corpusId (Proxy @HyperdataCorpus)
   let corpusLang = view (node_hyperdata . to _hc_lang) corpus_node
 
   let patterns = case termList of

src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs

@@ -46,7 +46,7 @@ flowPhylo :: (HasNodeStory env err m, HasDBid NodeType)
           -> m Phylo
 flowPhylo cId = do
 
-  corpus_node <- getNodeWith cId (Proxy @ HyperdataCorpus)
+  corpus_node <- getNodeWith cId (Proxy @HyperdataCorpus)
   let lang = withDefaultLanguage $ view (node_hyperdata . to _hc_lang) corpus_node
   list'    <- defaultList cId
   termList <- HashMap.toList <$> getTermsWith (Text.words . unNgramsTerm) [list'] NgramsTerms (Set.singleton MapTerm)

src/Gargantext/Database/Action/Flow.hs

@@ -659,7 +659,7 @@ reIndexWith :: ( HasNodeStory env err m )
             -> m ()
 reIndexWith cId lId nt lts = do
   -- printDebug "(cId,lId,nt,lts)" (cId, lId, nt, lts)
-  corpus_node <- getNodeWith cId (Proxy @ HyperdataCorpus)
+  corpus_node <- getNodeWith cId (Proxy @HyperdataCorpus)
   let corpusLang = withDefaultLanguage $ view (node_hyperdata . to _hc_lang) corpus_node
 
   -- Getting [NgramsTerm]

src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs

@@ -193,6 +193,20 @@ instance Arbitrary HyperdataContact where
 -- | Specific Gargantext instance
 instance Hyperdata HyperdataContact
 
+-- | All lenses
+makeLenses ''ContactWho
+makeLenses ''ContactWhere
+makeLenses ''ContactTouch
+makeLenses ''ContactMetaData
+makeLenses ''HyperdataContact
+
+-- | All Json instances
+$(deriveJSON (unPrefix "_ct_") ''ContactTouch)
+$(deriveJSON (unPrefix "_cw_") ''ContactWho)
+$(deriveJSON (unPrefix "_cw_") ''ContactWhere)
+$(deriveJSON (unPrefix "_cm_") ''ContactMetaData)
+$(deriveJSON (unPrefix "_hc_") ''HyperdataContact)
+
 -- | Database (Posgresql-simple instance)
 instance FromField HyperdataContact where
   fromField = fromField'
@@ -207,16 +221,3 @@ instance DefaultFromField (Nullable SqlJsonb) HyperdataContact where
 
 
 
--- | All lenses
-makeLenses ''ContactWho
-makeLenses ''ContactWhere
-makeLenses ''ContactTouch
-makeLenses ''ContactMetaData
-makeLenses ''HyperdataContact
-
--- | All Json instances
-$(deriveJSON (unPrefix "_cw_") ''ContactWho)
-$(deriveJSON (unPrefix "_cw_") ''ContactWhere)
-$(deriveJSON (unPrefix "_ct_") ''ContactTouch)
-$(deriveJSON (unPrefix "_cm_") ''ContactMetaData)
-$(deriveJSON (unPrefix "_hc_") ''HyperdataContact)

src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs

@@ -73,8 +73,6 @@ defaultHyperdataDocument = case decode docExample of
 data StatusV3  = StatusV3 { statusV3_error  :: !(Maybe Text)
                           , statusV3_action :: !(Maybe Text)
                       } deriving (Show, Generic)
-$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
-
 
 ------------------------------------------------------------------------
 data HyperdataDocumentV3 = HyperdataDocumentV3 { _hdv3_publication_day    :: !(Maybe Int)
@@ -140,12 +138,25 @@ arbitraryHyperdataDocuments =
 instance Hyperdata HyperdataDocument
 instance Hyperdata HyperdataDocumentV3
 ------------------------------------------------------------------------
-$(makeLenses ''HyperdataDocument)
-makePrisms ''HyperdataDocument
+-- $(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
+instance ToSchema HyperdataDocument where
+  declareNamedSchema proxy =
+    genericDeclareNamedSchema (unPrefixSwagger "_hd_") proxy
+    & mapped.schema.description ?~ "Document Hyperdata"
+    & mapped.schema.example ?~ toJSON defaultHyperdataDocument
 
-$(makeLenses ''HyperdataDocumentV3)
+{-
+-- | For now HyperdataDocumentV3 is not exposed with the API
+instance ToSchema HyperdataDocumentV3 where
+  declareNamedSchema proxy =
+    genericDeclareNamedSchema (unPrefixSwagger "hyperdataDocumentV3_") proxy
+    & mapped.schema.description ?~ "Document Hyperdata for Garg V3"
+    & mapped.schema.example ?~ toJSON defaultHyperdataDocumentV3
+-}
 
--- $(deriveJSON (unPrefix "_hd_") ''HyperdataDocument)
+--
+-- JSON instances
+--
 
 instance FromJSON HyperdataDocument
   where
@@ -167,24 +178,13 @@ instance ToJSON HyperdataDocument
 
 
 
+$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
 $(deriveJSON (unPrefix "_hdv3_") ''HyperdataDocumentV3)
 
-instance ToSchema HyperdataDocument where
-  declareNamedSchema proxy =
-    genericDeclareNamedSchema (unPrefixSwagger "_hd_") proxy
-    & mapped.schema.description ?~ "Document Hyperdata"
-    & mapped.schema.example ?~ toJSON defaultHyperdataDocument
+--
+-- FromField/ToField instances
+--
 
-{-
--- | For now HyperdataDocumentV3 is not exposed with the API
-instance ToSchema HyperdataDocumentV3 where
-  declareNamedSchema proxy =
-    genericDeclareNamedSchema (unPrefixSwagger "hyperdataDocumentV3_") proxy
-    & mapped.schema.description ?~ "Document Hyperdata for Garg V3"
-    & mapped.schema.example ?~ toJSON defaultHyperdataDocumentV3
--}
-
-------------------------------------------------------------------------
 instance FromField HyperdataDocument
   where
     fromField = fromField'
@@ -193,14 +193,12 @@ instance FromField HyperdataDocumentV3
   where
     fromField = fromField'
 
--------
 instance ToField HyperdataDocument where
   toField = toJSONField
 
 instance ToField HyperdataDocumentV3 where
   toField = toJSONField
 
-------------------------------------------------------------------------
 instance DefaultFromField SqlJsonb HyperdataDocument
   where
     defaultFromField = fromPGSFromField
@@ -208,4 +206,10 @@ instance DefaultFromField SqlJsonb HyperdataDocument
 instance DefaultFromField SqlJsonb HyperdataDocumentV3
   where
     defaultFromField = fromPGSFromField
-------------------------------------------------------------------------
+
+--
+-- Lenses
+--
+$(makeLenses ''HyperdataDocument)
+makePrisms ''HyperdataDocument
+$(makeLenses ''HyperdataDocumentV3)

src/Gargantext/Database/Admin/Types/Hyperdata/User.hs

@@ -98,9 +98,9 @@ makeLenses ''HyperdataPrivate
 makeLenses ''HyperdataPublic
 
 -- | All Json instances
-$(deriveJSON (unPrefix "_hu_")  ''HyperdataUser)
 $(deriveJSON (unPrefix "_hpr_") ''HyperdataPrivate)
 $(deriveJSON (unPrefix "_hpu_") ''HyperdataPublic)
+$(deriveJSON (unPrefix "_hu_")  ''HyperdataUser)
 
 -- | Arbitrary instances
 instance Arbitrary HyperdataUser where

src/Gargantext/Database/Admin/Types/Metrics.hs

@@ -41,8 +41,8 @@ instance Arbitrary Metric
                        <*> arbitrary
                        <*> arbitrary
 
-deriveJSON (unPrefix "metrics_") ''Metrics
 deriveJSON (unPrefix "m_") ''Metric
+deriveJSON (unPrefix "metrics_") ''Metrics
 
 
 newtype ChartMetrics a = ChartMetrics { chartMetrics_data :: a }

src/Gargantext/Database/Prelude.hs

@@ -119,7 +119,7 @@ fromInt64ToInt = fromIntegral
 mkCmd :: (Connection -> IO a) -> DBCmd err a
 mkCmd k = do
   pool <- view connPool
-  withResource pool (liftBase . k)
+  liftBase $ withResource pool (liftBase . k)
 
 runCmd :: (HasConnectionPool env)
        => env

src/Gargantext/Database/Query/Facet.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE TemplateHaskell           #-}
 {-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE TypeOperators             #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Query.Facet
   ( runViewAuthorsDoc

src/Gargantext/Database/Schema/User.hs

@@ -121,11 +121,11 @@ userTable = Table "auth_user"
                   }
       )
 
+$(deriveJSON (unPrefix "userLight_") ''UserLight)
+$(deriveJSON (unPrefix "user_") ''UserPoly)
+
 instance FromField UserLight where
   fromField = fromField'
 
 instance FromField UserDB where
   fromField = fromField'
-
-$(deriveJSON (unPrefix "userLight_") ''UserLight)
-$(deriveJSON (unPrefix "user_") ''UserPoly)

src/Gargantext/Utils/Jobs.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 module Gargantext.Utils.Jobs (
   -- * Serving the JOBS API
     serveJobsAPI

src/Gargantext/Utils/SpacyNLP.hs

@@ -15,71 +15,24 @@ Server to be used: https://gitlab.iscpif.fr/gargantext/spacy-server
 
 {-# LANGUAGE TemplateHaskell   #-}
 
-module Gargantext.Utils.SpacyNLP where
+module Gargantext.Utils.SpacyNLP (
+    module Gargantext.Utils.SpacyNLP.Types
+  , spacyRequest
+  , spacyTagsToToken
+  , spacyDataToPosSentences
+  , nlp
+  ) where
 
-import Control.Lens
 import Data.Aeson (encode)
-import Data.Aeson.TH (deriveJSON)
 import Data.Text hiding (map, group, filter, concat, zip)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Terms.Multi.PosTagging.Types
-import Gargantext.Core.Types (POS(..), NER(..))
-import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
 import Network.HTTP.Simple (parseRequest, httpJSON, setRequestBodyLBS, getResponseBody, Response)
 import Network.URI (URI(..))
+import Gargantext.Utils.SpacyNLP.Types
 
 
-data SpacyData = SpacyData { _spacy_data :: ![SpacyText]}
-  deriving (Show)
-
-data SpacyText = SpacyText { _spacy_text :: !Text
-                           , _spacy_tags :: ![SpacyTags]
-                           } deriving (Show)
-data SpacyTags =
-  SpacyTags { _spacyTags_text :: !Text
-            , _spacyTags_text_with_ws :: !Text
-            , _spacyTags_whitespace :: !Text
-            , _spacyTags_head :: !Text
-            , _spacyTags_head_index :: !Int
-            , _spacyTags_left_edge :: !Text
-            , _spacyTags_right_edge :: !Text
-            , _spacyTags_index :: Int
-            , _spacyTags_ent_type :: !NER
-            , _spacyTags_ent_iob :: !Text
-            , _spacyTags_lemma :: !Text
-            , _spacyTags_normalized :: !Text
-            , _spacyTags_shape :: !Text
-            , _spacyTags_prefix :: !Text
-            , _spacyTags_suffix :: !Text
-            , _spacyTags_is_alpha :: Bool
-            , _spacyTags_is_ascii :: Bool
-            , _spacyTags_is_digit :: Bool
-            , _spacyTags_is_title :: Bool
-            , _spacyTags_is_punct :: Bool
-            , _spacyTags_is_left_punct :: Bool
-            , _spacyTags_is_right_punct :: Bool
-            , _spacyTags_is_space :: Bool
-            , _spacyTags_is_bracket :: Bool
-            , _spacyTags_is_quote :: Bool
-            , _spacyTags_is_currency :: Bool
-            , _spacyTags_like_url :: Bool
-            , _spacyTags_like_num :: Bool
-            , _spacyTags_like_email :: Bool
-            , _spacyTags_is_oov :: Bool
-            , _spacyTags_is_stop :: Bool
-            , _spacyTags_pos :: POS
-            , _spacyTags_tag :: POS
-            , _spacyTags_dep :: !Text
-            , _spacyTags_lang :: !Text
-            , _spacyTags_prob :: !Int
-            , _spacyTags_char_offset :: !Int
-            } deriving (Show)
-
-
-data SpacyRequest = SpacyRequest { _spacyRequest_text :: !Text }
-  deriving (Show)
-
 spacyRequest :: URI -> Text -> IO SpacyData
 spacyRequest uri txt = do
   req <- parseRequest $ "POST " <> show (uri { uriPath = "/pos" })
@@ -87,30 +40,18 @@ spacyRequest uri txt = do
   result <- httpJSON request :: IO (Response SpacyData)
   pure $ getResponseBody result
 
-
--- Instances
-deriveJSON (unPrefix "_spacy_")        ''SpacyData
-deriveJSON (unPrefix "_spacy_")        ''SpacyText
-deriveJSON (unPrefix "_spacyTags_")    ''SpacyTags
-deriveJSON (unPrefix "_spacyRequest_") ''SpacyRequest
-
-makeLenses ''SpacyData
-makeLenses ''SpacyText
-makeLenses ''SpacyTags
-makeLenses ''SpacyRequest
-
 ----------------------------------------------------------------
 spacyTagsToToken :: SpacyTags -> Token
-spacyTagsToToken st = Token (st ^. spacyTags_index)
-                   (st ^. spacyTags_normalized)
-                   (st ^. spacyTags_text)
-                   (st ^. spacyTags_lemma)
-                   (st ^. spacyTags_head_index)
-                   (st ^. spacyTags_char_offset)
-                   (Just $ st ^. spacyTags_pos)
-                   (Just $ st ^. spacyTags_ent_type)
-                   (Just $ st ^. spacyTags_prefix)
-                   (Just $ st ^. spacyTags_suffix)
+spacyTagsToToken st = Token (_spacyTags_index st)
+                   (_spacyTags_normalized st)
+                   (_spacyTags_text st)
+                   (_spacyTags_lemma st)
+                   (_spacyTags_head_index st)
+                   (_spacyTags_char_offset st)
+                   (Just $ _spacyTags_pos st)
+                   (Just $ _spacyTags_ent_type st)
+                   (Just $ _spacyTags_prefix st)
+                   (Just $ _spacyTags_suffix st)
 
 spacyDataToPosSentences :: SpacyData -> PosSentences
 spacyDataToPosSentences (SpacyData ds) = PosSentences

src/Gargantext/Utils/SpacyNLP/Types.hs

+{-|
+Module      : Gargantext.Utils.SpacyNLP.Types
+Description : John Snow NLP API connexion
+Copyright   : (c) CNRS, 2017
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Spacy ecosystem: https://github.com/explosion/spaCy
+
+Server to be used: https://gitlab.iscpif.fr/gargantext/spacy-server
+
+-}
+
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Gargantext.Utils.SpacyNLP.Types where
+
+import Control.Lens
+import Data.Aeson.TH (deriveJSON)
+import Data.Text hiding (map, group, filter, concat, zip)
+import Gargantext.Core.Types (POS(..), NER(..))
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Prelude
+
+
+data SpacyData = SpacyData { _spacy_data :: ![SpacyText]}
+  deriving (Show)
+
+data SpacyText = SpacyText { _spacy_text :: !Text
+                           , _spacy_tags :: ![SpacyTags]
+                           } deriving (Show)
+data SpacyTags =
+  SpacyTags { _spacyTags_text :: !Text
+            , _spacyTags_text_with_ws :: !Text
+            , _spacyTags_whitespace :: !Text
+            , _spacyTags_head :: !Text
+            , _spacyTags_head_index :: !Int
+            , _spacyTags_left_edge :: !Text
+            , _spacyTags_right_edge :: !Text
+            , _spacyTags_index :: Int
+            , _spacyTags_ent_type :: !NER
+            , _spacyTags_ent_iob :: !Text
+            , _spacyTags_lemma :: !Text
+            , _spacyTags_normalized :: !Text
+            , _spacyTags_shape :: !Text
+            , _spacyTags_prefix :: !Text
+            , _spacyTags_suffix :: !Text
+            , _spacyTags_is_alpha :: Bool
+            , _spacyTags_is_ascii :: Bool
+            , _spacyTags_is_digit :: Bool
+            , _spacyTags_is_title :: Bool
+            , _spacyTags_is_punct :: Bool
+            , _spacyTags_is_left_punct :: Bool
+            , _spacyTags_is_right_punct :: Bool
+            , _spacyTags_is_space :: Bool
+            , _spacyTags_is_bracket :: Bool
+            , _spacyTags_is_quote :: Bool
+            , _spacyTags_is_currency :: Bool
+            , _spacyTags_like_url :: Bool
+            , _spacyTags_like_num :: Bool
+            , _spacyTags_like_email :: Bool
+            , _spacyTags_is_oov :: Bool
+            , _spacyTags_is_stop :: Bool
+            , _spacyTags_pos :: POS
+            , _spacyTags_tag :: POS
+            , _spacyTags_dep :: !Text
+            , _spacyTags_lang :: !Text
+            , _spacyTags_prob :: !Int
+            , _spacyTags_char_offset :: !Int
+            } deriving (Show)
+
+
+data SpacyRequest = SpacyRequest { _spacyRequest_text :: !Text }
+  deriving (Show)
+
+--
+-- JSON instances
+--
+
+deriveJSON (unPrefix "_spacyTags_")    ''SpacyTags
+deriveJSON (unPrefix "_spacy_")        ''SpacyText
+deriveJSON (unPrefix "_spacy_")        ''SpacyData
+deriveJSON (unPrefix "_spacyRequest_") ''SpacyRequest
+
+--
+-- Lenses
+--
+
+makeLenses ''SpacyData
+makeLenses ''SpacyText
+makeLenses ''SpacyTags
+makeLenses ''SpacyRequest
+

stack.yaml

@@ -148,6 +148,11 @@ extra-deps:
 - tmp-postgres-1.34.1.0
 - vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
 - wai-3.2.4
+- morpheus-graphql-0.24.3
+- morpheus-graphql-app-0.24.3
+- morpheus-graphql-core-0.24.3
+- morpheus-graphql-server-0.24.3
+- morpheus-graphql-subscriptions-0.24.3
 
 # For the graph clustering
 ghc-options: