Make a start on the remote (streaming) endpoints

It typechecks but it exchange only a very simple string and
it prints it.

gargantext.cabal

@@ -149,6 +149,7 @@ library
       Gargantext.API.Prelude
       Gargantext.API.Public.Types
       Gargantext.API.Routes
+      Gargantext.API.Routes.Client
       Gargantext.API.Routes.Named
       Gargantext.API.Routes.Named.Annuaire
       Gargantext.API.Routes.Named.Contact
@@ -165,6 +166,7 @@ library
       Gargantext.API.Routes.Named.Private
       Gargantext.API.Routes.Named.Public
       Gargantext.API.Routes.Named.Publish
+      Gargantext.API.Routes.Named.Remote
       Gargantext.API.Routes.Named.Search
       Gargantext.API.Routes.Named.Share
       Gargantext.API.Routes.Named.Table
@@ -342,6 +344,7 @@ library
       Gargantext.API.Server.Named.Ngrams
       Gargantext.API.Server.Named.Private
       Gargantext.API.Server.Named.Public
+      Gargantext.API.Server.Named.Remote
       Gargantext.API.Server.Named.Viz
       Gargantext.API.Swagger
       Gargantext.API.Table
@@ -589,11 +592,13 @@ library
     , serialise ^>= 0.2.4.0
     , servant >= 0.20.1 && < 0.21
     , servant-auth ^>= 0.4.0.0
+    , servant-auth-client
     , servant-auth-server ^>=0.4.6.0
     , servant-auth-swagger ^>= 0.2.10.1
     , servant-blaze ^>= 0.9.1
     , servant-client >= 0.20 && < 0.21
     , servant-client-core >= 0.20 && < 0.21
+    , servant-conduit >= 0.15 && < 0.17
     , servant-ekg ^>= 0.3.1
     , servant-routes < 0.2
     , servant-openapi3 >= 2.0.1.6
@@ -745,6 +750,8 @@ common testDependencies
     , servant-auth-client
     , servant-client >= 0.20 && < 0.21
     , servant-client-core >= 0.20 && < 0.21
+    , servant-conduit >= 0.15 && < 0.17
+    , servant-server >= 0.18.3 && < 0.21
     , servant-websockets >= 2.0.0 && < 2.1
     , shelly >= 1.9 && < 2
     , stm >= 2.5.1.0 && < 2.6

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

@@ -80,6 +80,8 @@ newtype RemoteTransferPublicKey =
   deriving newtype (ToJSON, FromJSON)
   deriving anyclass (ToSchema)
 
+instance NFData RemoteTransferPublicKey where
+
 pubKeyToRemotePubKey :: RSA.PublicKey -> RemoteTransferPublicKey
 pubKeyToRemotePubKey pubKey =
   let x509pubKey = X509.PubKeyRSA pubKey
@@ -107,6 +109,8 @@ data AuthResponse = AuthResponse { _authRes_token   :: Token
                                  }
   deriving (Generic, Eq, Show)
 
+instance NFData AuthResponse where
+
 type Token  = Text
 type TreeId = NodeId
 

src/Gargantext/API/Admin/EnvTypes.hs

@@ -47,7 +47,7 @@ import Data.Text qualified as T
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude (GargM, IsGargServer)
-import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasRemoteTransferKeys(..))
+import Gargantext.Core.Config (GargConfig(..), gc_mail_config, gc_nlp_config, HasJWTSettings(..), HasConfig(..), HasRemoteTransferKeys(..), HasManager(..))
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
 import Gargantext.Core.NodeStory
@@ -152,6 +152,9 @@ instance CET.HasCentralExchangeNotification Env where
 instance HasRemoteTransferKeys Env where
   remoteTransferKeys = env_remote_transfer_keys
 
+instance HasManager Env where
+  gargHttpManager = env_manager
+
 data FireWall = FireWall { unFireWall :: Bool }
 
 data MockEnv = MockEnv
@@ -184,6 +187,7 @@ instance HasLogger (GargM DevEnv BackendInternalError) where
 
 data DevEnv = DevEnv
   { _dev_env_config    :: !GargConfig
+  , _dev_env_manager   :: ~Manager
   , _dev_env_logger    :: !(Logger (GargM DevEnv BackendInternalError))
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
@@ -242,6 +246,9 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
 instance HasMail DevEnv where
   mailSettings = dev_env_config . gc_mail_config
 
+instance HasManager DevEnv where
+  gargHttpManager = dev_env_manager
+
 instance HasNLPServer DevEnv where
   nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)
 

src/Gargantext/API/Dev.hs

@@ -14,19 +14,20 @@ module Gargantext.API.Dev where
 
 import Control.Lens (view)
 import Control.Monad (fail)
-import Data.Pool (withResource)
 import Database.PostgreSQL.Simple qualified as PGS
+import Data.Pool (withResource)
 import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
 import Gargantext.API.Admin.Settings ( newPool )
 import Gargantext.API.Errors.Types ( BackendInternalError )
 import Gargantext.API.Prelude ( GargM )
 import Gargantext.Core.Config (_gc_database_config)
 import Gargantext.Core.Config.Types (SettingsFile(..))
+import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
 import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
 import Gargantext.Prelude
-import Gargantext.Core.Config.Utils (readConfig)
 import Gargantext.System.Logging ( withLoggerHoisted )
+import Network.HTTP.Client.TLS (newTlsManager)
 import Servant ( ServerError )
 
 -------------------------------------------------------------------
@@ -41,8 +42,10 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
       --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool (_gc_database_config cfg)
       nodeStory_env <- fromDBNodeStoryEnv pool
+      manager <- newTlsManager
       pure $ DevEnv
         { _dev_env_pool     = pool
+        , _dev_env_manager    = manager
         , _dev_env_logger     = logger
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_config   = cfg

src/Gargantext/API/Errors/Types.hs

@@ -48,8 +48,8 @@ module Gargantext.API.Errors.Types (
 
 import Control.Lens ((#), makePrisms, Prism')
 import Control.Monad.Fail (fail)
-import Data.Aeson (Value(..), (.:), (.=), object, withObject)
 import Data.Aeson.Types (typeMismatch, emptyArray)
+import Data.Aeson (Value(..), (.:), (.=), object, withObject)
 import Data.List.NonEmpty qualified as NE
 import Data.Singletons.TH ( SingI(sing), SingKind(fromSing) )
 import Data.Text qualified as T

src/Gargantext/API/HashedResponse.hs

@@ -19,6 +19,8 @@ import Gargantext.Prelude.Crypto.Hash qualified as Crypto (hash)
 data HashedResponse a = HashedResponse { hash :: Text, value :: a }
   deriving (Generic)
 
+instance NFData a => NFData (HashedResponse a) where
+
 instance ToSchema a => ToSchema (HashedResponse a)
 instance ToJSON a => ToJSON (HashedResponse a) where
   toJSON = genericToJSON defaultOptions

src/Gargantext/API/Ngrams/Types.hs

@@ -16,6 +16,7 @@ Portability : POSIX
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# OPTIONS -fno-warn-orphans     #-}  -- some instances are orphaned here
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Gargantext.API.Ngrams.Types where
 
@@ -98,6 +99,8 @@ newtype MSet a = MSet (Map a ())
   deriving newtype (Semigroup, Monoid)
   deriving anyclass (ToExpr)
 
+instance NFData a => NFData (MSet a) where
+
 instance ToJSON a => ToJSON (MSet a) where
   toJSON     (MSet m) = toJSON     (Map.keys m)
   toEncoding (MSet m) = toEncoding (Map.keys m)
@@ -171,6 +174,7 @@ instance FromField NgramsRepoElement where
   fromField = fromJSONField
 instance ToField NgramsRepoElement where
   toField = toJSONField
+instance NFData NgramsRepoElement where
 
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
@@ -201,6 +205,7 @@ newNgramsElement mayList ngrams =
 
 instance ToSchema NgramsElement where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
+instance NFData NgramsElement where
 
 ------------------------------------------------------------------------
 newtype NgramsTable = NgramsTable [NgramsElement]
@@ -209,6 +214,7 @@ newtype NgramsTable = NgramsTable [NgramsElement]
   deriving anyclass (ToExpr)
 
 -- type NgramsList = NgramsTable
+instance NFData NgramsTable where
 
 makePrisms ''NgramsTable
 
@@ -379,6 +385,10 @@ newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
   deriving stock (Eq, Show, Generic)
   deriving newtype (Validity, Semigroup, Monoid, Group, Transformable, Composable)
 
+deriving anyclass instance (NFData k, NFData v) => NFData (PatchMap k v)
+deriving anyclass instance NFData a => NFData (Replace a)
+instance NFData a => NFData (PatchMSet a) where
+
 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 unPatchMSet (PatchMSet a) = a
 
@@ -441,6 +451,8 @@ data NgramsPatch
                    }
       deriving (Eq, Show, Generic)
 
+instance NFData NgramsPatch where
+
 -- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
 -- TODO: the empty object should be accepted and treated as mempty.
 deriveJSON (unPrefixUntagged "_") ''NgramsPatch
@@ -532,6 +544,8 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
   deriving stock (Eq, Show, Generic)
   deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 
+instance NFData NgramsTablePatch
+
 mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
 mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
 
@@ -683,6 +697,7 @@ deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
 instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
   declareNamedSchema = wellNamedSchema "_v_"
+instance NFData a => NFData (Versioned a) where
 ------------------------------------------------------------------------
 type Count = Int
 
@@ -697,6 +712,7 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 makeLenses ''VersionedWithCount
 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
   declareNamedSchema = wellNamedSchema "_vc_"
+instance NFData a => NFData (VersionedWithCount a) where
 
 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_

src/Gargantext/API/Prelude.hs

@@ -23,7 +23,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError)
 import Gargantext.API.Errors.Types (HasServerError(..), serverError)
 import Gargantext.Core.Notifications.CentralExchange.Types (HasCentralExchangeNotification)
-import Gargantext.Core.Config (HasConfig)
+import Gargantext.Core.Config (HasConfig, HasManager)
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv)
@@ -45,6 +45,7 @@ type EnvC env =
   , HasNodeStoryEnv   env
   , HasMail           env
   , HasNLPServer      env
+  , HasManager        env
   , HasCentralExchangeNotification env
   )
 

src/Gargantext/API/Routes/Client.hs

+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Gargantext.API.Routes.Client where
+
+import Conduit qualified as C
+import Data.Proxy
+import Data.Text.Encoding qualified as TE
+import Gargantext.API.Admin.Auth.Types qualified as Auth
+import Gargantext.API.Errors (GargErrorScheme(..))
+import Gargantext.API.Routes.Named
+import Gargantext.API.Routes.Named.Private (mkPrivateAPI, remoteAPI)
+import Gargantext.API.Routes.Named.Remote qualified as Named
+import Gargantext.Prelude
+import Network.HTTP.Types qualified as H
+import Servant.API.WebSocket qualified as WS
+import Servant.Auth.Client qualified as S
+import Servant.Client.Core
+import Servant.Client.Generic (genericClient)
+import Servant.Client.Streaming
+import Servant.Conduit ()
+
+instance RunClient m => HasClient m WS.WebSocketPending where
+  type Client m WS.WebSocketPending = H.Method ->  m ()
+
+  clientWithRoute :: Proxy m -> Proxy WS.WebSocketPending -> Request -> Client m WS.WebSocketPending
+  clientWithRoute _pm Proxy _req _httpMethod = do
+    panicTrace "[WebSocket client] this is not implemented!"
+
+  hoistClientMonad _ _ f cl = \meth -> f (cl meth)
+
+-- | The client for the full API. It also serves as a \"proof\" that our
+-- whole API has all the required instances to be used in a client.
+clientRoutes :: API (AsClientT ClientM)
+clientRoutes = genericClient
+
+remoteImportClient :: Auth.Token
+                   -> C.ConduitT () Named.RemoteBinaryData IO ()
+                   -> ClientM (C.ConduitT () Named.RemoteBinaryData IO ())
+remoteImportClient (S.Token . TE.encodeUtf8 -> token) c =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & remoteAPI
+               & Named.remoteAPI
+               & Named.remoteImportEp
+               & ($ c)

src/Gargantext/API/Routes/Named/Private.hs

@@ -26,23 +26,24 @@ module Gargantext.API.Routes.Named.Private (
 
 
 import Data.Text (Text)
-import GHC.Generics (Generic)
-import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
-import Gargantext.API.Auth.PolicyCheck (PolicyChecked)
-import Gargantext.API.Routes.Named.Contact (ContactAPI)
-import Gargantext.API.Routes.Named.Context (ContextAPI)
-import Gargantext.API.Routes.Named.Corpus (AddWithForm, AddWithQuery, CorpusExportAPI, MakeSubcorpusAPI)
-import Gargantext.API.Routes.Named.Count (CountAPI, Query)
-import Gargantext.API.Routes.Named.Document (DocumentExportAPI)
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Auth.PolicyCheck
+import Gargantext.API.Routes.Named.Contact
+import Gargantext.API.Routes.Named.Context
+import Gargantext.API.Routes.Named.Corpus
+import Gargantext.API.Routes.Named.Count
+import Gargantext.API.Routes.Named.Document
 import Gargantext.API.Routes.Named.List (GETAPI, JSONAPI, TSVAPI)
-import Gargantext.API.Routes.Named.Node (NodeAPI, NodesAPI, NodeNodeAPI, Roots)
-import Gargantext.API.Routes.Named.Share (ShareURL)
-import Gargantext.API.Routes.Named.Table (TableNgramsAPI)
-import Gargantext.API.Routes.Named.Tree (NodeTreeAPI, TreeFlatAPI)
-import Gargantext.API.Routes.Named.Viz (GraphAPI, PhyloExportAPI)
-import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
-import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataAnnuaire, HyperdataCorpus)
-import Gargantext.Database.Admin.Types.Node (ContextId, CorpusId, DocId, NodeId)
+import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Remote
+import Gargantext.API.Routes.Named.Share
+import Gargantext.API.Routes.Named.Table
+import Gargantext.API.Routes.Named.Tree
+import Gargantext.API.Routes.Named.Viz
+import Gargantext.Database.Admin.Types.Hyperdata.Any
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+import Gargantext.Database.Admin.Types.Node
+import GHC.Generics
 import Servant.API
 import Servant.Auth qualified as SA
 
@@ -101,6 +102,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , listJsonAPI      :: mode :- NamedRoutes JSONAPI
   , listTsvAPI       :: mode :- NamedRoutes TSVAPI
   , shareUrlAPI      :: mode :- "shareurl" :> NamedRoutes ShareURL
+  , remoteAPI        :: mode :- NamedRoutes RemoteAPI
   } deriving Generic
 
 

src/Gargantext/API/Routes/Named/Remote.hs

+
+{-# LANGUAGE TypeOperators #-}
+module Gargantext.API.Routes.Named.Remote (
+  -- * Routes types
+    RemoteAPI(..)
+  , RemoteAPI'(..)
+  , RemoteExportRequest(..)
+  , RemoteBinaryData(..)
+  ) where
+
+import Data.Aeson as JSON
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString qualified as BS
+import Data.Proxy
+import Data.Swagger hiding (Http)
+import Gargantext.API.Admin.Auth.Types (Token)
+import Gargantext.Database.Admin.Types.Node ( NodeId (..) )
+import GHC.Generics
+import Prelude
+import Servant.API
+import Servant.Client.Core.BaseUrl
+import Test.QuickCheck
+import qualified Conduit as C
+
+
+data RemoteAPI mode = RemoteAPI
+  { remoteAPI     :: mode :- "remote" :> NamedRoutes RemoteAPI'
+  } deriving Generic
+
+data RemoteExportRequest =
+  RemoteExportRequest
+  { -- | The ID of the node we wish to export
+    _rer_node_id        :: NodeId
+    -- | The URL of the instance we want to copy data to.
+  , _rer_instance_url  :: BaseUrl
+    -- | The JWT token to use for authentication purposes.
+  , _rer_instance_auth :: Token
+  } deriving (Show, Eq, Generic)
+
+instance Arbitrary RemoteExportRequest where
+  arbitrary = RemoteExportRequest <$> arbitrary <*> (pure (BaseUrl Http "dev.sub.gargantext.org" 8008 "")) <*> arbitrary
+
+instance ToJSON RemoteExportRequest where
+  toJSON RemoteExportRequest{..}
+    = JSON.object [ "node_id" .= toJSON _rer_node_id
+                  , "instance_url"  .= toJSON _rer_instance_url
+                  , "instance_auth" .= toJSON _rer_instance_auth
+                  ]
+
+instance FromJSON RemoteExportRequest where
+  parseJSON = withObject "RemoteExportRequest" $ \o -> do
+    _rer_node_id       <- o .: "node_id"
+    _rer_instance_url  <- maybe (fail "RemoteExportRequest invalid URL") pure =<< (parseBaseUrl <$> o .: "instance_url")
+    _rer_instance_auth <- o .: "instance_auth"
+    pure RemoteExportRequest{..}
+
+instance ToSchema RemoteExportRequest where
+  declareNamedSchema _ =
+    let exampleS = RemoteExportRequest (UnsafeMkNodeId 42) (BaseUrl Http "dev.sub.gargantext.org" 8008 "") ("abcdef")
+    in pure $ NamedSchema (Just "RemoteExportRequest") $ sketchStrictSchema exampleS
+
+newtype RemoteBinaryData = RemoteBinaryData { getRemoteBinaryData :: BS.ByteString }
+  deriving (Show, Eq, Ord)
+
+instance Accept RemoteBinaryData where
+  contentType _ = contentType (Proxy :: Proxy OctetStream)
+
+instance MimeRender OctetStream RemoteBinaryData where
+    mimeRender _ (RemoteBinaryData bs) = BL.fromStrict bs
+
+instance MimeUnrender OctetStream RemoteBinaryData where
+    mimeUnrender _ bs = Right (RemoteBinaryData $ BS.toStrict bs)
+
+instance ToSchema RemoteBinaryData where
+  declareNamedSchema _ = pure $ NamedSchema (Just "RemoteExportRequest") binarySchema
+
+data RemoteAPI' mode = RemoteAPI'
+  { remoteExportEp :: mode :- "export" :> ReqBody '[JSON] RemoteExportRequest :> Post '[JSON] ()
+  , remoteImportEp :: mode :- "import" :> StreamBody NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
+                                       :> StreamPost NoFraming OctetStream (C.ConduitT () RemoteBinaryData IO ())
+  } deriving Generic

src/Gargantext/API/Routes/Named/Share.hs

@@ -13,14 +13,14 @@ module Gargantext.API.Routes.Named.Share (
   , ShareNodeParams(..)
   ) where
 
-import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+import Data.Aeson (withText)
 import Data.Swagger (ToSchema, declareNamedSchema)
 import Data.Text qualified as T
-import GHC.Generics (Generic)
 import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
-import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Prelude
 import Network.URI (parseURI)
-import Prelude
+import Prelude (fail)
 import Servant
 
 -- | A shareable link.
@@ -31,6 +31,8 @@ import Servant
 newtype ShareLink = ShareLink { getShareLink :: URI }
   deriving (Show, Eq, Ord, Generic)
 
+instance NFData ShareLink where
+
 renderShareLink :: ShareLink -> T.Text
 renderShareLink = T.pack . show . getShareLink
 

src/Gargantext/API/Server/Named/Private.hs

@@ -10,17 +10,18 @@ import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Members (members)
 import Gargantext.API.Ngrams.List qualified as List
 import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots)
-import Gargantext.API.Node qualified as Tree
 import Gargantext.API.Node.Contact as Contact
 import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
 import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
 import Gargantext.API.Node.Document.Export (documentExportAPI)
 import Gargantext.API.Node.Phylo.Export qualified as PhyloExport
+import Gargantext.API.Node qualified as Tree
 import Gargantext.API.Node.ShareURL ( shareURL )
 import Gargantext.API.Prelude (GargM)
 import Gargantext.API.Routes (addCorpusWithForm, addCorpusWithQuery)
 import Gargantext.API.Routes.Named.Private qualified as Named
-import Gargantext.API.Server.Named.Ngrams (apiNgramsTableDoc)
+import Gargantext.API.Server.Named.Ngrams
+import Gargantext.API.Server.Named.Remote qualified as Remote
 import Gargantext.API.Server.Named.Viz qualified as Viz
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
@@ -66,4 +67,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI
        , shareUrlAPI       = shareURL
+       , remoteAPI         = Remote.remoteAPI
        }

src/Gargantext/API/Server/Named/Remote.hs

+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Gargantext.API.Server.Named.Remote (
+  remoteAPI
+  ) where
+
+import Codec.Serialise
+import Conduit
+import Control.Lens (view)
+import Data.ByteString.Builder qualified as B
+import Data.ByteString.Char8 qualified as C8
+import Data.ByteString.Lazy qualified as BL
+import Data.Conduit.Combinators qualified as C
+import Data.Conduit.List qualified as CL
+import Gargantext.API.Prelude (IsGargServer)
+import Gargantext.API.Routes.Client (remoteImportClient)
+import Gargantext.API.Routes.Named.Remote qualified as Named
+import Gargantext.Core.Config
+import Prelude
+import Servant.Client.Streaming (mkClientEnv, withClientM, ClientError)
+import Servant.Server.Generic (AsServerT)
+
+remoteAPI :: (MonadIO m, IsGargServer env err m) => Named.RemoteAPI (AsServerT m)
+remoteAPI = Named.RemoteAPI $
+  Named.RemoteAPI'
+    { remoteExportEp = remoteExportHandler
+    , remoteImportEp = pure
+    }
+
+type ExpectedPayload = C8.ByteString -- FIXME(adn)
+
+remoteImportHandler :: (MonadIO m, Serialise a) => ConduitT () Named.RemoteBinaryData IO () -> m a
+remoteImportHandler c = liftIO $ do
+  chunks <- sourceToList $ c .| C.map (B.byteString . Named.getRemoteBinaryData)
+  case deserialiseOrFail (B.toLazyByteString $ mconcat chunks) of
+    Left err    -> liftIO $ error $ "Deserialization error: " ++ show err
+    Right value -> pure value
+
+remoteExportHandler :: ( MonadIO m
+                       , IsGargServer err env m
+                       )
+                    => Named.RemoteExportRequest
+                    -> m ()
+remoteExportHandler Named.RemoteExportRequest{..} = do
+  mgr  <- view gargHttpManager
+  -- FIXME(adn) eventually we want to be sending nodes here.
+  let node = C8.pack "hello world"
+  result <- liftIO $ withClientM (remoteImportClient _rer_instance_auth (streamEncoder node)) (mkClientEnv mgr _rer_instance_url) streamDecode
+  liftIO $ putStrLn (show (result :: ExpectedPayload))
+
+streamEncoder :: Serialise a => a -> ConduitT () Named.RemoteBinaryData IO ()
+streamEncoder = CL.sourceList . map Named.RemoteBinaryData . BL.toChunks . serialise
+
+streamDecode :: Either ClientError (ConduitT () Named.RemoteBinaryData IO ()) -> IO ExpectedPayload
+streamDecode = \case
+  Left err -> error $ show err -- FIXME(adn) How to deal with the error properly?
+  Right c  -> remoteImportHandler c

src/Gargantext/API/ThrowAll.hs

@@ -30,6 +30,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types (BackendInternalError)
 import Gargantext.API.Prelude (GargM, _ServerError)
 import Gargantext.API.Routes.Named.Private qualified as Named
+import Gargantext.API.Routes.Named.Remote () -- instance MimeUnrenderer
 import Gargantext.API.Server.Named.Private qualified as Named
 import Gargantext.Database.Admin.Types.Node (UserId (..))
 import Gargantext.Prelude hiding (Handler)
@@ -37,6 +38,7 @@ import Network.HTTP.Types.Status (Status(..))
 import Network.Wai (responseLBS)
 import Servant
 import Servant.Auth.Server (AuthResult(..))
+import Servant.Conduit ()
 import Servant.Server.Generic (AsServerT)
 
 -- | Slightly more general version of the 'ThrowAll' typeclass from Servant,

src/Gargantext/Core.hs

@@ -57,6 +57,8 @@ data Lang = DE
           | ZH
   deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, GQLType)
 
+instance NFData Lang where
+
 -- | Defaults to 'EN' in all those places where a language is mandatory,
 -- but an optional one has been passed.
 withDefaultLanguage :: Maybe Lang -> Lang

src/Gargantext/Core/Config.hs

@@ -36,6 +36,7 @@ module Gargantext.Core.Config (
   , HasJWTSettings(..)
   , HasConfig(..)
   , HasRemoteTransferKeys(..)
+  , HasManager(..)
   ) where
 
 import Control.Lens (Getter)
@@ -48,6 +49,7 @@ import Gargantext.Core.Config.NLP (NLPConfig)
 import Gargantext.Core.Config.Types
 import Gargantext.Core.Config.Worker (WorkerSettings)
 import Gargantext.Prelude
+import Network.HTTP.Client qualified as HTTP
 import Servant.Auth.Server (JWTSettings)
 import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
 import Toml.Schema
@@ -139,3 +141,6 @@ class HasJWTSettings env where
 
 class HasRemoteTransferKeys env where
   remoteTransferKeys :: Getter env (RSA.PublicKey, RSA.PrivateKey)
+
+class HasManager env where
+  gargHttpManager :: Getter env HTTP.Manager

src/Gargantext/Core/Types.hs

@@ -185,6 +185,8 @@ $(deriveJSON (unPrefix "tr_") ''TableResult)
 instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where
   declareNamedSchema = wellNamedSchema "tr_"
 
+instance NFData a => NFData (TableResult a) where
+
 ----------------------------------------------------------------------------
 data Typed a b =
   Typed { _withType :: a

src/Gargantext/Core/Types/Individu.hs

@@ -57,7 +57,9 @@ instance Prelude.Show GargPassword where
 instance ToJSON GargPassword
 instance FromJSON GargPassword
 
-instance ToSchema GargPassword
+instance ToSchema GargPassword where
+  declareNamedSchema _ = pure $ NamedSchema (Just "GargPassword") passwordSchema
+
 type Email          = Text
 type UsernameMaster = Username
 type UsernameSimple = Username

src/Gargantext/Core/Types/Main.hs

@@ -40,6 +40,8 @@ data NodeTree = NodeTree { _nt_name           :: Text
                          , _nt_publish_policy :: Maybe NodePublishPolicy
                          } deriving (Show, Read, Generic)
 
+instance NFData NodeTree where
+
 instance Eq NodeTree where
   (==) d1 d2 = _nt_id d1 == _nt_id d2
 
@@ -56,6 +58,7 @@ type TypeId     = Int
 data ListType  =  CandidateTerm | StopTerm | MapTerm
   deriving (Generic, Eq, Ord, Show, Read, Enum, Bounded, ToExpr)
 
+instance NFData ListType where
 instance ToJSON   ListType
 instance FromJSON ListType
 instance ToSchema ListType
@@ -115,6 +118,8 @@ fromListTypeId = flip Bimap.lookupR listTypeIds
 data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
   deriving (Show, Read, Eq, Generic, Ord)
 
+instance NFData a => NFData (Tree a) where
+
 $(deriveJSON (unPrefix "_tn_") ''Tree)
 
 instance (Typeable a, ToSchema a) => ToSchema (Tree a) where

src/Gargantext/Core/Worker/Types.hs

+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-|
 Module      : Gargantext.Core.Worker.Types
 Description : Some useful worker types
@@ -36,4 +38,4 @@ instance FromJSON JobInfo where
 instance ToJSON JobInfo where
   toJSON (JobInfo { .. }) = object [ "message_id" .= _ji_message_id 
                                    , "node_id"    .= _ji_mNode_id ]
-
+instance NFData JobInfo

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

@@ -21,6 +21,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 newtype HyperdataAny = HyperdataAny Object
   deriving (Show, Generic, ToJSON, FromJSON)
 
+instance NFData HyperdataAny
+
 ------------------------------------------------------------------------
 -- Instances
 ------------------------------------------------------------------------

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

@@ -39,6 +39,8 @@ data HyperdataContact =
 instance GQLType HyperdataContact where
   directives _ = typeDirective DropNamespace { dropNamespace = "_hc_" }
 
+instance NFData HyperdataContact where
+
 instance HasText HyperdataContact
   where
     hasText = undefined
@@ -95,6 +97,8 @@ data ContactWho =
 instance GQLType ContactWho where
   directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
 
+instance NFData ContactWho where
+
 type FirstName = Text
 type LastName  = Text
 
@@ -113,15 +117,11 @@ contactWho fn ln =
 data ContactWhere =
   ContactWhere { _cw_organization :: [Text]
                , _cw_labTeamDepts :: [Text]
-               
                , _cw_role         :: Maybe Text
-               
                , _cw_office       :: Maybe Text
                , _cw_country      :: Maybe Text
                , _cw_city         :: Maybe Text
-               
                , _cw_touch        :: Maybe ContactTouch
-               
                , _cw_entry        :: Maybe NUTCTime
                , _cw_exit         :: Maybe NUTCTime
   } deriving (Eq, Show, Generic)
@@ -129,6 +129,8 @@ data ContactWhere =
 instance GQLType ContactWhere where
   directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
 
+instance NFData ContactWhere where
+
 defaultContactWhere :: ContactWhere
 defaultContactWhere =
   ContactWhere
@@ -151,6 +153,8 @@ data ContactTouch =
 instance GQLType ContactTouch where
   directives _ = typeDirective DropNamespace { dropNamespace = "_ct_" }
 
+instance NFData ContactTouch where
+
 defaultContactTouch :: ContactTouch
 defaultContactTouch =
   ContactTouch

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

@@ -40,6 +40,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd                :: !(Maybe T
                                            }
   deriving (Show, Generic)
 
+instance NFData HyperdataDocument
 
 instance HasText HyperdataDocument
   where

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

@@ -40,6 +40,8 @@ data HyperdataUser =
 instance GQLType HyperdataUser where
   directives _ = typeDirective DropNamespace { dropNamespace = "_hu_" }
 
+instance NFData HyperdataUser where
+
 data HyperdataPrivate =
      HyperdataPrivate { _hpr_password :: !Text
                       , _hpr_lang     :: !Lang
@@ -49,6 +51,8 @@ data HyperdataPrivate =
 instance GQLType HyperdataPrivate where
   directives _ = typeDirective DropNamespace { dropNamespace = "_hpr_" }
 
+instance NFData HyperdataPrivate where
+
 
 data HyperdataPublic =
      HyperdataPublic { _hpu_pseudo       :: !Text
@@ -59,6 +63,8 @@ data HyperdataPublic =
 instance GQLType HyperdataPublic where
   directives _ = typeDirective DropNamespace { dropNamespace = "_hpu_" }
 
+instance NFData HyperdataPublic where
+
 -- | Default
 defaultHyperdataUser :: HyperdataUser
 defaultHyperdataUser =

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

@@ -69,6 +69,8 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int }
   deriving stock (Show, Eq, Ord, Generic)
   deriving newtype (ToSchema, ToJSON, FromJSON, FromField, ToField, Hashable)
 
+instance NFData UserId where
+
 -- The 'UserId' is isomprohic to an 'Int'.
 instance GQLType UserId where
   type KIND UserId = SCALAR
@@ -257,6 +259,8 @@ newtype NodeId = UnsafeMkNodeId { _NodeId :: Int }
   deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
   deriving anyclass (ToExpr)
 
+instance NFData NodeId where
+
 instance ResourceId NodeId where
   isPositive = (> 0) . _NodeId
 
@@ -291,6 +295,7 @@ newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
   deriving FromField via NodeId
 
 instance ToParamSchema ContextId
+instance NFData ContextId
 
 instance Arbitrary ContextId where
   arbitrary = UnsafeMkContextId . getPositive <$> arbitrary
@@ -443,6 +448,7 @@ data NodeType
   deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
 
 instance GQLType NodeType
+instance NFData NodeType where
 
 -- /NOTE/ (adn) For backward-compatibility reasons, we keep the format for ToJSON/FromJSON similar
 -- to what 'Show/Read' would generate, but we otherwise generate \"by hand\" the mapping between a
@@ -650,6 +656,8 @@ data NodePublishPolicy
   | NPP_publish_edits_only_owner_or_super
   deriving (Show, Read, Generic, Eq, Ord, Enum, Bounded)
 
+instance NFData NodePublishPolicy where
+
 instance HasDBid NodePublishPolicy where
   toDBid = \case
     NPP_publish_no_edits_allowed

src/Gargantext/Database/Query/Facet/Types.hs

@@ -56,6 +56,8 @@ data Facet id date hyperdata score =
               } deriving (Show, Generic)
 -}
 
+instance (NFData id, NFData created, NFData title, NFData hyper, NFData cat, NFData count, NFData score) =>
+  NFData (Facet id created title hyper cat count score) where
 
 
 data Pair i l = Pair {

src/Gargantext/Database/Schema/Node.hs

@@ -19,6 +19,7 @@ module Gargantext.Database.Schema.Node where
 import Control.Lens hiding (elements, (&))
 import Gargantext.Database.Schema.Prelude
 import Prelude hiding (null, id, map, sum)
+import Gargantext.Prelude (NFData(..))
 
 ------------------------------------------------------------------------
 -- Main polymorphic Node definition
@@ -43,6 +44,9 @@ data NodePoly id
           , _node_hyperdata :: !hyperdata
           } deriving (Show, Generic)
 
+instance (NFData i, NFData h, NFData t, NFData u, NFData p, NFData n, NFData d, NFData hy) =>
+  NFData (NodePoly i h t u p n d hy) where
+
 ------------------------------------------------------------------------
 -- Automatic instances derivation
 $(deriveJSON (unPrefix "_node_") ''NodePoly)

src/Gargantext/Orphans/OpenAPI.hs

@@ -7,16 +7,17 @@
 {-# LANGUAGE LambdaCase #-}
 module Gargantext.Orphans.OpenAPI where
 
+import Conduit qualified as C
 import Control.Lens
 import Data.HashMap.Strict.InsOrd qualified as HM
 import Data.OpenApi as OpenAPI hiding (Header, Server)
 import Data.OpenApi.Declare
+import Data.Swagger.Declare qualified as SwaggerDeclare
 import Data.Swagger.Internal qualified as Swagger
 import Data.Swagger qualified as Swagger
 import Data.Text qualified as T
 import Data.Typeable
 import Prelude
-import qualified Data.Swagger.Declare as SwaggerDeclare
 import Servant.API
 import Servant.Auth
 import Servant.OpenApi
@@ -85,6 +86,9 @@ class SwaggerConvertible a b where
 -- Instances
 --
 
+instance Typeable b => ToSchema (C.ConduitT () b IO ()) where
+  declareNamedSchema _ = pure $ NamedSchema Nothing binarySchema
+
 instance SwaggerConvertible OpenAPI.Discriminator T.Text where
   swagConv = iso OpenAPI._discriminatorPropertyName convertDiscriminator
     where

src/Gargantext/Utils/UTCTime.hs

@@ -35,6 +35,7 @@ import Test.QuickCheck hiding (label)
 
 newtype NUTCTime = NUTCTime UTCTime
   deriving (Eq, Show, Generic)
+  deriving newtype NFData
 instance DecodeScalar NUTCTime where
   decodeScalar (DMT.String x) = case (readEither $ T.unpack x) of
     Right r  -> pure $ NUTCTime r

test/Test/API/Authentication.hs

@@ -25,7 +25,7 @@ import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Types.Status (status403)
 import Prelude qualified
 import Servant.Auth.Client ()
-import Servant.Client
+import Servant.Client.Streaming
 import Servant.Client.Core.Response qualified as SR
 import Servant.Client.Generic (genericClient)
 import Test.API.Routes (auth_api)

test/Test/API/Private.hs

@@ -16,7 +16,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
 import Servant.Auth.Client ()
-import Servant.Client
+import Servant.Client.Streaming
 import Servant.Client.Generic (genericClient)
 import Test.API.Prelude
 import Test.API.Private.Move  qualified as Move

test/Test/API/Private/Move.hs

@@ -11,7 +11,7 @@ import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
 import Gargantext.Prelude
-import Servant.Client
+import Servant.Client.Streaming
 import Test.API.Prelude
 import Test.API.Routes
 import Test.API.Setup

test/Test/API/Private/Share.hs

@@ -18,7 +18,7 @@ import Gargantext.Core.Types.Individu
 import Gargantext.Prelude
 import Prelude (fail)
 import Servant.Auth.Client qualified as SC
-import Servant.Client
+import Servant.Client.Streaming
 import Test.API.Prelude (newCorpusForUser)
 import Test.API.Routes
 import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort)

test/Test/API/Private/Table.hs

@@ -11,7 +11,7 @@ import Gargantext.Core.Types
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude
-import Servant.Client
+import Servant.Client.Streaming
 import Test.API.Prelude (checkEither)
 import Test.API.Routes
 import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort)

test/Test/API/Routes.hs

@@ -37,6 +37,7 @@ import Gargantext.API.Errors
 import Gargantext.API.HashedResponse (HashedResponse)
 import Gargantext.API.Ngrams.List.Types (WithJsonFile, WithTextFile)
 import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount )
+import Gargantext.API.Routes.Client
 import Gargantext.API.Routes.Named
 import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp)
 import Gargantext.API.Routes.Named.Node hiding (treeAPI)
@@ -59,19 +60,10 @@ import Network.HTTP.Types qualified as H
 import Network.Wai.Handler.Warp (Port)
 import Servant.API.WebSocket qualified as WS
 import Servant.Auth.Client qualified as S
-import Servant.Client (ClientM)
 import Servant.Client.Core (RunClient, HasClient(..), Request)
 import Servant.Client.Generic ( genericClient, AsClientT )
-
-
-instance RunClient m => HasClient m WS.WebSocketPending where
-  type Client m WS.WebSocketPending = H.Method ->  m ()
-
-  clientWithRoute :: Proxy m -> Proxy WS.WebSocketPending -> Request -> Client m WS.WebSocketPending
-  clientWithRoute _pm Proxy _req _httpMethod = do
-    panicTrace "[WebSocket client] this is not implemented!"
-
-  hoistClientMonad _ _ f cl = \meth -> f (cl meth)
+import Servant.Client.Streaming
+import Servant.Conduit ()
 
 
 -- This is for requests made by http.client directly to hand-crafted URLs.
@@ -85,12 +77,6 @@ mkUrl _port urlPiece =
 gqlUrl :: ByteString
 gqlUrl = "/gql"
 
-
--- | The client for the full API. It also serves as a \"proof\" that our
--- whole API has all the required instances to be used in a client.
-clientRoutes :: API (AsClientT ClientM)
-clientRoutes = genericClient
-
 -- This is for Servant.Client requests
 auth_api :: AuthRequest -> ClientM AuthResponse
 auth_api = clientRoutes & apiWithCustomErrorScheme

test/Test/API/UpdateList.hs

@@ -62,7 +62,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
-import Servant.Client
+import Servant.Client.Streaming
 import System.FilePath
 import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser)
 import Test.API.Routes (mkUrl, gqlUrl, get_table_ngrams, put_table_ngrams, toServantToken, clientRoutes, get_table, update_node, add_form_to_list, add_tsv_to_list)

test/Test/Offline/JSON.hs

@@ -13,6 +13,7 @@ import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Routes.Named.Publish (PublishRequest)
+import Gargantext.API.Routes.Named.Remote
 import Gargantext.API.Viz.Types
 import Gargantext.Core.Types.Phylo
 import Gargantext.Core.Viz.Phylo qualified as VizPhylo
@@ -56,6 +57,7 @@ tests = testGroup "JSON" [
   , testProperty "Datafield roundtrips"      (jsonRoundtrip @Datafield)
   , testProperty "WithQuery roundtrips"      (jsonRoundtrip @WithQuery)
   , testProperty "PublishRequest roundtrips" (jsonRoundtrip @PublishRequest)
+  , testProperty "RemoteExportRequest roundtrips" (jsonRoundtrip @RemoteExportRequest)
   , testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip
   , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
   , testProperty "NodeType roundtrips"      (jsonEnumRoundtrip (Dict @_ @NodeType))

test/Test/Server/ReverseProxy.hs

@@ -8,7 +8,7 @@ import Network.HTTP.Client
 import Network.HTTP.Types.Status
 import Prelude
 import Servant.Auth.Client (Token(..))
-import Servant.Client
+import Servant.Client.Streaming
 import Servant.Client.Generic (genericClient)
 import Test.API.Setup (setupEnvironment, withBackendServerAndProxy, createAliceAndBob)
 import Test.Hspec

test/Test/Utils.hs

@@ -61,7 +61,7 @@ import Network.Wai.Handler.Warp (Port)
 import Network.Wai.Test (SResponse(..))
 import Network.WebSockets qualified as WS
 import Prelude qualified
-import Servant.Client (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
+import Servant.Client.Streaming (ClientEnv, baseUrlPort, mkClientEnv, parseBaseUrl, runClientM, makeClientRequest, defaultMakeClientRequest)
 import Servant.Client.Core (BaseUrl)
 import Servant.Client.Core.Request qualified as Client
 import System.Environment (lookupEnv)