WIP: make a start on the remote (streaming) endpoints

gargantext.cabal

@@ -164,6 +164,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
@@ -340,6 +341,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

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/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
 
@@ -97,6 +98,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)
@@ -170,6 +173,7 @@ instance FromField NgramsRepoElement where
   fromField = fromJSONField
 instance ToField NgramsRepoElement where
   toField = toJSONField
+instance NFData NgramsRepoElement where
 
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
@@ -378,6 +382,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
 
@@ -440,6 +448,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
@@ -531,6 +541,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
 
@@ -682,6 +694,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
 
@@ -696,6 +709,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/Routes/Named/Private.hs

@@ -36,6 +36,7 @@ import Gargantext.API.Routes.Named.Count
 import Gargantext.API.Routes.Named.Document
 import Gargantext.API.Routes.Named.List qualified as List
 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
@@ -101,6 +102,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , listJsonAPI      :: mode :- NamedRoutes List.JSONAPI
   , listTsvAPI       :: mode :- NamedRoutes List.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
+
+
+data RemoteAPI mode = RemoteAPI
+  { remoteAPI     :: mode :- "remote" :> NamedRoutes RemoteAPI'
+  } deriving Generic
+
+data RemoteExportRequest =
+  RemoteExportRequest
+  { -- | The ID of the node we wish to export
+    _rer_nodeId        :: 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 (Generic)
+
+instance ToJSON RemoteExportRequest where
+  toJSON RemoteExportRequest{..}
+    = JSON.object [ "node_id" .= toJSON _rer_nodeId
+                  , "instance_url"  .= toJSON _rer_instance_url
+                  , "instance_auth" .= toJSON _rer_instance_auth
+                  ]
+
+instance FromJSON RemoteExportRequest where
+  parseJSON = withObject "RemoteExportRequest" $ \o -> do
+    _rer_nodeId        <- 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 (SourceIO RemoteBinaryData)
+                                       :> StreamPost NoFraming OctetStream (SourceIO RemoteBinaryData)
+  } deriving Generic

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

@@ -16,12 +16,12 @@ module Gargantext.API.Routes.Named.Share (
 import Data.Aeson
 import Data.Swagger
 import Data.Text qualified as T
-import GHC.Generics
 import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
 import Gargantext.Database.Admin.Types.Node
+import Gargantext.Prelude
 import Network.URI (parseURI)
-import Prelude
 import Servant
+import Prelude (fail)
 
 -- | A shareable link.
 -- N.B. We don't use a 'BareUrl' internally, because parsing something like
@@ -29,7 +29,9 @@ import Servant
 -- would fail because '#/share/NodeCorpus/16' by the RFC3968 spec is considered
 -- an uriFragment, but BaseUrl cannot handle that.
 newtype ShareLink = ShareLink { getShareLink :: URI }
-  deriving (Show, Eq, Ord)
+  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

@@ -20,6 +20,7 @@ import Gargantext.API.Prelude
 import Gargantext.API.Routes (addCorpusWithForm, addCorpusWithQuery)
 import Gargantext.API.Routes.Named.Private qualified as Named
 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
@@ -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

+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+module Gargantext.API.Server.Named.Remote (
+  remoteAPI
+  ) where
+
+import Gargantext.API.Prelude (IsGargServer)
+ -- (NodePoly(..))
+import Gargantext.Prelude
+import Servant.Server.Generic (AsServerT)
+import qualified Gargantext.API.Routes.Named.Remote as Named
+
+remoteAPI :: IsGargServer env err m => Named.RemoteAPI (AsServerT m)
+remoteAPI = Named.RemoteAPI $
+  Named.RemoteAPI'
+    { remoteExportEp = error "todo"
+    , remoteImportEp = error "todo"
+    }
+

src/Gargantext/API/ThrowAll.hs

@@ -30,6 +30,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types
 import Gargantext.API.Prelude
 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)

src/Gargantext/Core/Types.hs

@@ -184,6 +184,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

@@ -55,7 +55,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

@@ -39,6 +39,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
 
@@ -55,6 +57,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
@@ -114,6 +117,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/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/Node.hs

@@ -68,6 +68,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
@@ -256,6 +258,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
 
@@ -442,6 +446,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
@@ -649,6 +654,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

@@ -55,6 +55,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 {

test/Test/API/Authentication.hs

@@ -23,7 +23,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/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/Routes.hs

@@ -58,9 +58,9 @@ 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 )
+import Servant.Client.Streaming
 import Servant.Job.Async
 import Gargantext.API.Routes.Named.Publish (PublishAPI(..))
 

test/Test/API/UpdateList.hs

@@ -53,18 +53,14 @@ import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
 import Gargantext.Core.Text.Ngrams
 import Gargantext.Core.Types ( CorpusId, ListId, NodeId, _NodeId, TableResult(..))
-import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Core.Types.Individu
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Core.Worker.Types (JobInfo)
-import Gargantext.Database.Action.User
-import Gargantext.Database.Admin.Types.Hyperdata.Corpus
-import Gargantext.Database.Admin.Types.Hyperdata.Folder (defaultHyperdataFolderPrivate)
 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

@@ -56,6 +56,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

@@ -59,7 +59,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)