Commit d5096e40 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Make a start on the remote (streaming) endpoints

It typechecks but it exchange only a very simple string and
it prints it.
parent 3ea32b50
...@@ -149,6 +149,7 @@ library ...@@ -149,6 +149,7 @@ library
Gargantext.API.Prelude Gargantext.API.Prelude
Gargantext.API.Public.Types Gargantext.API.Public.Types
Gargantext.API.Routes Gargantext.API.Routes
Gargantext.API.Routes.Client
Gargantext.API.Routes.Named Gargantext.API.Routes.Named
Gargantext.API.Routes.Named.Annuaire Gargantext.API.Routes.Named.Annuaire
Gargantext.API.Routes.Named.Contact Gargantext.API.Routes.Named.Contact
...@@ -165,6 +166,7 @@ library ...@@ -165,6 +166,7 @@ library
Gargantext.API.Routes.Named.Private Gargantext.API.Routes.Named.Private
Gargantext.API.Routes.Named.Public Gargantext.API.Routes.Named.Public
Gargantext.API.Routes.Named.Publish Gargantext.API.Routes.Named.Publish
Gargantext.API.Routes.Named.Remote
Gargantext.API.Routes.Named.Search Gargantext.API.Routes.Named.Search
Gargantext.API.Routes.Named.Share Gargantext.API.Routes.Named.Share
Gargantext.API.Routes.Named.Table Gargantext.API.Routes.Named.Table
...@@ -342,6 +344,7 @@ library ...@@ -342,6 +344,7 @@ library
Gargantext.API.Server.Named.Ngrams Gargantext.API.Server.Named.Ngrams
Gargantext.API.Server.Named.Private Gargantext.API.Server.Named.Private
Gargantext.API.Server.Named.Public Gargantext.API.Server.Named.Public
Gargantext.API.Server.Named.Remote
Gargantext.API.Server.Named.Viz Gargantext.API.Server.Named.Viz
Gargantext.API.Swagger Gargantext.API.Swagger
Gargantext.API.Table Gargantext.API.Table
...@@ -589,11 +592,13 @@ library ...@@ -589,11 +592,13 @@ library
, serialise ^>= 0.2.4.0 , serialise ^>= 0.2.4.0
, servant >= 0.20.1 && < 0.21 , servant >= 0.20.1 && < 0.21
, servant-auth ^>= 0.4.0.0 , servant-auth ^>= 0.4.0.0
, servant-auth-client
, servant-auth-server ^>=0.4.6.0 , servant-auth-server ^>=0.4.6.0
, servant-auth-swagger ^>= 0.2.10.1 , servant-auth-swagger ^>= 0.2.10.1
, servant-blaze ^>= 0.9.1 , servant-blaze ^>= 0.9.1
, servant-client >= 0.20 && < 0.21 , servant-client >= 0.20 && < 0.21
, servant-client-core >= 0.20 && < 0.21 , servant-client-core >= 0.20 && < 0.21
, servant-conduit >= 0.15 && < 0.17
, servant-ekg ^>= 0.3.1 , servant-ekg ^>= 0.3.1
, servant-routes < 0.2 , servant-routes < 0.2
, servant-openapi3 >= 2.0.1.6 , servant-openapi3 >= 2.0.1.6
...@@ -745,6 +750,8 @@ common testDependencies ...@@ -745,6 +750,8 @@ common testDependencies
, servant-auth-client , servant-auth-client
, servant-client >= 0.20 && < 0.21 , servant-client >= 0.20 && < 0.21
, servant-client-core >= 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 , servant-websockets >= 2.0.0 && < 2.1
, shelly >= 1.9 && < 2 , shelly >= 1.9 && < 2
, stm >= 2.5.1.0 && < 2.6 , stm >= 2.5.1.0 && < 2.6
......
...@@ -80,6 +80,8 @@ newtype RemoteTransferPublicKey = ...@@ -80,6 +80,8 @@ newtype RemoteTransferPublicKey =
deriving newtype (ToJSON, FromJSON) deriving newtype (ToJSON, FromJSON)
deriving anyclass (ToSchema) deriving anyclass (ToSchema)
instance NFData RemoteTransferPublicKey where
pubKeyToRemotePubKey :: RSA.PublicKey -> RemoteTransferPublicKey pubKeyToRemotePubKey :: RSA.PublicKey -> RemoteTransferPublicKey
pubKeyToRemotePubKey pubKey = pubKeyToRemotePubKey pubKey =
let x509pubKey = X509.PubKeyRSA pubKey let x509pubKey = X509.PubKeyRSA pubKey
...@@ -107,6 +109,8 @@ data AuthResponse = AuthResponse { _authRes_token :: Token ...@@ -107,6 +109,8 @@ data AuthResponse = AuthResponse { _authRes_token :: Token
} }
deriving (Generic, Eq, Show) deriving (Generic, Eq, Show)
instance NFData AuthResponse where
type Token = Text type Token = Text
type TreeId = NodeId type TreeId = NodeId
......
...@@ -47,7 +47,7 @@ import Data.Text qualified as T ...@@ -47,7 +47,7 @@ import Data.Text qualified as T
import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Prelude (GargM, IsGargServer) 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.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap) import Gargantext.Core.NLP (HasNLPServer(..), nlpServerMap)
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
...@@ -152,6 +152,9 @@ instance CET.HasCentralExchangeNotification Env where ...@@ -152,6 +152,9 @@ instance CET.HasCentralExchangeNotification Env where
instance HasRemoteTransferKeys Env where instance HasRemoteTransferKeys Env where
remoteTransferKeys = env_remote_transfer_keys remoteTransferKeys = env_remote_transfer_keys
instance HasManager Env where
gargHttpManager = env_manager
data FireWall = FireWall { unFireWall :: Bool } data FireWall = FireWall { unFireWall :: Bool }
data MockEnv = MockEnv data MockEnv = MockEnv
...@@ -184,6 +187,7 @@ instance HasLogger (GargM DevEnv BackendInternalError) where ...@@ -184,6 +187,7 @@ instance HasLogger (GargM DevEnv BackendInternalError) where
data DevEnv = DevEnv data DevEnv = DevEnv
{ _dev_env_config :: !GargConfig { _dev_env_config :: !GargConfig
, _dev_env_manager :: ~Manager
, _dev_env_logger :: !(Logger (GargM DevEnv BackendInternalError)) , _dev_env_logger :: !(Logger (GargM DevEnv BackendInternalError))
, _dev_env_pool :: !(Pool Connection) , _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv , _dev_env_nodeStory :: !NodeStoryEnv
...@@ -242,6 +246,9 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where ...@@ -242,6 +246,9 @@ instance HasNodeArchiveStoryImmediateSaver DevEnv where
instance HasMail DevEnv where instance HasMail DevEnv where
mailSettings = dev_env_config . gc_mail_config mailSettings = dev_env_config . gc_mail_config
instance HasManager DevEnv where
gargHttpManager = dev_env_manager
instance HasNLPServer DevEnv where instance HasNLPServer DevEnv where
nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap) nlpServer = dev_env_config . gc_nlp_config . (to nlpServerMap)
......
...@@ -14,19 +14,20 @@ module Gargantext.API.Dev where ...@@ -14,19 +14,20 @@ module Gargantext.API.Dev where
import Control.Lens (view) import Control.Lens (view)
import Control.Monad (fail) import Control.Monad (fail)
import Data.Pool (withResource)
import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
import Data.Pool (withResource)
import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) ) import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
import Gargantext.API.Admin.Settings ( newPool ) import Gargantext.API.Admin.Settings ( newPool )
import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Prelude ( GargM ) import Gargantext.API.Prelude ( GargM )
import Gargantext.Core.Config (_gc_database_config) import Gargantext.Core.Config (_gc_database_config)
import Gargantext.Core.Config.Types (SettingsFile(..)) import Gargantext.Core.Config.Types (SettingsFile(..))
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv) import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd) import Gargantext.Database.Prelude (Cmd, CmdRandom, connPool, runCmd)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.System.Logging ( withLoggerHoisted ) import Gargantext.System.Logging ( withLoggerHoisted )
import Network.HTTP.Client.TLS (newTlsManager)
import Servant ( ServerError ) import Servant ( ServerError )
------------------------------------------------------------------- -------------------------------------------------------------------
...@@ -41,8 +42,10 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do ...@@ -41,8 +42,10 @@ withDevEnv settingsFile k = withLoggerHoisted Dev $ \logger -> do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg) --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool (_gc_database_config cfg) pool <- newPool (_gc_database_config cfg)
nodeStory_env <- fromDBNodeStoryEnv pool nodeStory_env <- fromDBNodeStoryEnv pool
manager <- newTlsManager
pure $ DevEnv pure $ DevEnv
{ _dev_env_pool = pool { _dev_env_pool = pool
, _dev_env_manager = manager
, _dev_env_logger = logger , _dev_env_logger = logger
, _dev_env_nodeStory = nodeStory_env , _dev_env_nodeStory = nodeStory_env
, _dev_env_config = cfg , _dev_env_config = cfg
......
...@@ -48,8 +48,8 @@ module Gargantext.API.Errors.Types ( ...@@ -48,8 +48,8 @@ module Gargantext.API.Errors.Types (
import Control.Lens ((#), makePrisms, Prism') import Control.Lens ((#), makePrisms, Prism')
import Control.Monad.Fail (fail) import Control.Monad.Fail (fail)
import Data.Aeson (Value(..), (.:), (.=), object, withObject)
import Data.Aeson.Types (typeMismatch, emptyArray) import Data.Aeson.Types (typeMismatch, emptyArray)
import Data.Aeson (Value(..), (.:), (.=), object, withObject)
import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NE
import Data.Singletons.TH ( SingI(sing), SingKind(fromSing) ) import Data.Singletons.TH ( SingI(sing), SingKind(fromSing) )
import Data.Text qualified as T import Data.Text qualified as T
......
...@@ -19,6 +19,8 @@ import Gargantext.Prelude.Crypto.Hash qualified as Crypto (hash) ...@@ -19,6 +19,8 @@ import Gargantext.Prelude.Crypto.Hash qualified as Crypto (hash)
data HashedResponse a = HashedResponse { hash :: Text, value :: a } data HashedResponse a = HashedResponse { hash :: Text, value :: a }
deriving (Generic) deriving (Generic)
instance NFData a => NFData (HashedResponse a) where
instance ToSchema a => ToSchema (HashedResponse a) instance ToSchema a => ToSchema (HashedResponse a)
instance ToJSON a => ToJSON (HashedResponse a) where instance ToJSON a => ToJSON (HashedResponse a) where
toJSON = genericToJSON defaultOptions toJSON = genericToJSON defaultOptions
......
...@@ -16,6 +16,7 @@ Portability : POSIX ...@@ -16,6 +16,7 @@ Portability : POSIX
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-} -- some instances are orphaned here {-# OPTIONS -fno-warn-orphans #-} -- some instances are orphaned here
{-# LANGUAGE StandaloneDeriving #-}
module Gargantext.API.Ngrams.Types where module Gargantext.API.Ngrams.Types where
...@@ -98,6 +99,8 @@ newtype MSet a = MSet (Map a ()) ...@@ -98,6 +99,8 @@ newtype MSet a = MSet (Map a ())
deriving newtype (Semigroup, Monoid) deriving newtype (Semigroup, Monoid)
deriving anyclass (ToExpr) deriving anyclass (ToExpr)
instance NFData a => NFData (MSet a) where
instance ToJSON a => ToJSON (MSet a) where instance ToJSON a => ToJSON (MSet a) where
toJSON (MSet m) = toJSON (Map.keys m) toJSON (MSet m) = toJSON (Map.keys m)
toEncoding (MSet m) = toEncoding (Map.keys m) toEncoding (MSet m) = toEncoding (Map.keys m)
...@@ -171,6 +174,7 @@ instance FromField NgramsRepoElement where ...@@ -171,6 +174,7 @@ instance FromField NgramsRepoElement where
fromField = fromJSONField fromField = fromJSONField
instance ToField NgramsRepoElement where instance ToField NgramsRepoElement where
toField = toJSONField toField = toJSONField
instance NFData NgramsRepoElement where
data NgramsElement = data NgramsElement =
NgramsElement { _ne_ngrams :: NgramsTerm NgramsElement { _ne_ngrams :: NgramsTerm
...@@ -201,6 +205,7 @@ newNgramsElement mayList ngrams = ...@@ -201,6 +205,7 @@ newNgramsElement mayList ngrams =
instance ToSchema NgramsElement where instance ToSchema NgramsElement where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
instance NFData NgramsElement where
------------------------------------------------------------------------ ------------------------------------------------------------------------
newtype NgramsTable = NgramsTable [NgramsElement] newtype NgramsTable = NgramsTable [NgramsElement]
...@@ -209,6 +214,7 @@ newtype NgramsTable = NgramsTable [NgramsElement] ...@@ -209,6 +214,7 @@ newtype NgramsTable = NgramsTable [NgramsElement]
deriving anyclass (ToExpr) deriving anyclass (ToExpr)
-- type NgramsList = NgramsTable -- type NgramsList = NgramsTable
instance NFData NgramsTable where
makePrisms ''NgramsTable makePrisms ''NgramsTable
...@@ -379,6 +385,10 @@ newtype PatchMSet a = PatchMSet (PatchMap a AddRem) ...@@ -379,6 +385,10 @@ newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
deriving newtype (Validity, Semigroup, Monoid, Group, Transformable, Composable) 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 -> PatchMap a AddRem
unPatchMSet (PatchMSet a) = a unPatchMSet (PatchMSet a) = a
...@@ -441,6 +451,8 @@ data NgramsPatch ...@@ -441,6 +451,8 @@ data NgramsPatch
} }
deriving (Eq, Show, Generic) 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. -- 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. -- TODO: the empty object should be accepted and treated as mempty.
deriveJSON (unPrefixUntagged "_") ''NgramsPatch deriveJSON (unPrefixUntagged "_") ''NgramsPatch
...@@ -532,6 +544,8 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch) ...@@ -532,6 +544,8 @@ newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable) deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
instance NFData NgramsTablePatch
mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
mkNgramsTablePatch = NgramsTablePatch . PM.fromMap mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
...@@ -683,6 +697,7 @@ deriveJSON (unPrefix "_v_") ''Versioned ...@@ -683,6 +697,7 @@ deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned makeLenses ''Versioned
instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
declareNamedSchema = wellNamedSchema "_v_" declareNamedSchema = wellNamedSchema "_v_"
instance NFData a => NFData (Versioned a) where
------------------------------------------------------------------------ ------------------------------------------------------------------------
type Count = Int type Count = Int
...@@ -697,6 +712,7 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount ...@@ -697,6 +712,7 @@ deriveJSON (unPrefix "_vc_") ''VersionedWithCount
makeLenses ''VersionedWithCount makeLenses ''VersionedWithCount
instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
declareNamedSchema = wellNamedSchema "_vc_" declareNamedSchema = wellNamedSchema "_vc_"
instance NFData a => NFData (VersionedWithCount a) where
toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_ toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
......
...@@ -23,7 +23,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError) ...@@ -23,7 +23,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError) import Gargantext.API.Errors.Class (HasAuthenticationError, _AuthenticationError)
import Gargantext.API.Errors.Types (HasServerError(..), serverError) import Gargantext.API.Errors.Types (HasServerError(..), serverError)
import Gargantext.Core.Notifications.CentralExchange.Types (HasCentralExchangeNotification) 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.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv) import Gargantext.Core.NodeStory (HasNodeStory, HasNodeStoryEnv)
...@@ -45,6 +45,7 @@ type EnvC env = ...@@ -45,6 +45,7 @@ type EnvC env =
, HasNodeStoryEnv env , HasNodeStoryEnv env
, HasMail env , HasMail env
, HasNLPServer env , HasNLPServer env
, HasManager env
, HasCentralExchangeNotification env , HasCentralExchangeNotification env
) )
......
{-# 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)
...@@ -26,23 +26,24 @@ module Gargantext.API.Routes.Named.Private ( ...@@ -26,23 +26,24 @@ module Gargantext.API.Routes.Named.Private (
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser) import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.Auth.PolicyCheck (PolicyChecked) import Gargantext.API.Routes.Named.Contact
import Gargantext.API.Routes.Named.Contact (ContactAPI) import Gargantext.API.Routes.Named.Context
import Gargantext.API.Routes.Named.Context (ContextAPI) import Gargantext.API.Routes.Named.Corpus
import Gargantext.API.Routes.Named.Corpus (AddWithForm, AddWithQuery, CorpusExportAPI, MakeSubcorpusAPI) import Gargantext.API.Routes.Named.Count
import Gargantext.API.Routes.Named.Count (CountAPI, Query) import Gargantext.API.Routes.Named.Document
import Gargantext.API.Routes.Named.Document (DocumentExportAPI)
import Gargantext.API.Routes.Named.List (GETAPI, JSONAPI, TSVAPI) import Gargantext.API.Routes.Named.List (GETAPI, JSONAPI, TSVAPI)
import Gargantext.API.Routes.Named.Node (NodeAPI, NodesAPI, NodeNodeAPI, Roots) import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.Share (ShareURL) import Gargantext.API.Routes.Named.Remote
import Gargantext.API.Routes.Named.Table (TableNgramsAPI) import Gargantext.API.Routes.Named.Share
import Gargantext.API.Routes.Named.Tree (NodeTreeAPI, TreeFlatAPI) import Gargantext.API.Routes.Named.Table
import Gargantext.API.Routes.Named.Viz (GraphAPI, PhyloExportAPI) import Gargantext.API.Routes.Named.Tree
import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny) import Gargantext.API.Routes.Named.Viz
import Gargantext.Database.Admin.Types.Hyperdata.Corpus (HyperdataAnnuaire, HyperdataCorpus) import Gargantext.Database.Admin.Types.Hyperdata.Any
import Gargantext.Database.Admin.Types.Node (ContextId, CorpusId, DocId, NodeId) import Gargantext.Database.Admin.Types.Hyperdata.Corpus
import Gargantext.Database.Admin.Types.Node
import GHC.Generics
import Servant.API import Servant.API
import Servant.Auth qualified as SA import Servant.Auth qualified as SA
...@@ -101,6 +102,7 @@ data GargPrivateAPI' mode = GargPrivateAPI' ...@@ -101,6 +102,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
, listJsonAPI :: mode :- NamedRoutes JSONAPI , listJsonAPI :: mode :- NamedRoutes JSONAPI
, listTsvAPI :: mode :- NamedRoutes TSVAPI , listTsvAPI :: mode :- NamedRoutes TSVAPI
, shareUrlAPI :: mode :- "shareurl" :> NamedRoutes ShareURL , shareUrlAPI :: mode :- "shareurl" :> NamedRoutes ShareURL
, remoteAPI :: mode :- NamedRoutes RemoteAPI
} deriving Generic } deriving Generic
......
{-# 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
...@@ -13,14 +13,14 @@ module Gargantext.API.Routes.Named.Share ( ...@@ -13,14 +13,14 @@ module Gargantext.API.Routes.Named.Share (
, ShareNodeParams(..) , ShareNodeParams(..)
) where ) where
import Data.Aeson (FromJSON(..), ToJSON(..), withText) import Data.Aeson (withText)
import Data.Swagger (ToSchema, declareNamedSchema) import Data.Swagger (ToSchema, declareNamedSchema)
import Data.Text qualified as T import Data.Text qualified as T
import GHC.Generics (Generic)
import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) ) 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 Network.URI (parseURI)
import Prelude import Prelude (fail)
import Servant import Servant
-- | A shareable link. -- | A shareable link.
...@@ -31,6 +31,8 @@ import Servant ...@@ -31,6 +31,8 @@ import Servant
newtype ShareLink = ShareLink { getShareLink :: URI } newtype ShareLink = ShareLink { getShareLink :: URI }
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)
instance NFData ShareLink where
renderShareLink :: ShareLink -> T.Text renderShareLink :: ShareLink -> T.Text
renderShareLink = T.pack . show . getShareLink renderShareLink = T.pack . show . getShareLink
......
...@@ -10,17 +10,18 @@ import Gargantext.API.Errors.Types (BackendInternalError) ...@@ -10,17 +10,18 @@ import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Members (members) import Gargantext.API.Members (members)
import Gargantext.API.Ngrams.List qualified as List import Gargantext.API.Ngrams.List qualified as List
import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots) 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.Contact as Contact
import Gargantext.API.Node.Corpus.Export qualified as CorpusExport import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
import Gargantext.API.Node.Document.Export (documentExportAPI) import Gargantext.API.Node.Document.Export (documentExportAPI)
import Gargantext.API.Node.Phylo.Export qualified as PhyloExport 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.Node.ShareURL ( shareURL )
import Gargantext.API.Prelude (GargM) import Gargantext.API.Prelude (GargM)
import Gargantext.API.Routes (addCorpusWithForm, addCorpusWithQuery) import Gargantext.API.Routes (addCorpusWithForm, addCorpusWithQuery)
import Gargantext.API.Routes.Named.Private qualified as Named 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.API.Server.Named.Viz qualified as Viz
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
...@@ -66,4 +67,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId) ...@@ -66,4 +67,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
, listJsonAPI = List.jsonAPI , listJsonAPI = List.jsonAPI
, listTsvAPI = List.tsvAPI , listTsvAPI = List.tsvAPI
, shareUrlAPI = shareURL , shareUrlAPI = shareURL
, remoteAPI = Remote.remoteAPI
} }
{-# 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
...@@ -30,6 +30,7 @@ import Gargantext.API.Admin.EnvTypes (Env) ...@@ -30,6 +30,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types (BackendInternalError) import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Prelude (GargM, _ServerError) import Gargantext.API.Prelude (GargM, _ServerError)
import Gargantext.API.Routes.Named.Private qualified as Named 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.API.Server.Named.Private qualified as Named
import Gargantext.Database.Admin.Types.Node (UserId (..)) import Gargantext.Database.Admin.Types.Node (UserId (..))
import Gargantext.Prelude hiding (Handler) import Gargantext.Prelude hiding (Handler)
...@@ -37,6 +38,7 @@ import Network.HTTP.Types.Status (Status(..)) ...@@ -37,6 +38,7 @@ import Network.HTTP.Types.Status (Status(..))
import Network.Wai (responseLBS) import Network.Wai (responseLBS)
import Servant import Servant
import Servant.Auth.Server (AuthResult(..)) import Servant.Auth.Server (AuthResult(..))
import Servant.Conduit ()
import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
-- | Slightly more general version of the 'ThrowAll' typeclass from Servant, -- | Slightly more general version of the 'ThrowAll' typeclass from Servant,
......
...@@ -57,6 +57,8 @@ data Lang = DE ...@@ -57,6 +57,8 @@ data Lang = DE
| ZH | ZH
deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, GQLType) 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, -- | Defaults to 'EN' in all those places where a language is mandatory,
-- but an optional one has been passed. -- but an optional one has been passed.
withDefaultLanguage :: Maybe Lang -> Lang withDefaultLanguage :: Maybe Lang -> Lang
......
...@@ -36,6 +36,7 @@ module Gargantext.Core.Config ( ...@@ -36,6 +36,7 @@ module Gargantext.Core.Config (
, HasJWTSettings(..) , HasJWTSettings(..)
, HasConfig(..) , HasConfig(..)
, HasRemoteTransferKeys(..) , HasRemoteTransferKeys(..)
, HasManager(..)
) where ) where
import Control.Lens (Getter) import Control.Lens (Getter)
...@@ -48,6 +49,7 @@ import Gargantext.Core.Config.NLP (NLPConfig) ...@@ -48,6 +49,7 @@ import Gargantext.Core.Config.NLP (NLPConfig)
import Gargantext.Core.Config.Types import Gargantext.Core.Config.Types
import Gargantext.Core.Config.Worker (WorkerSettings) import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Prelude import Gargantext.Prelude
import Network.HTTP.Client qualified as HTTP
import Servant.Auth.Server (JWTSettings) import Servant.Auth.Server (JWTSettings)
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl) import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import Toml.Schema import Toml.Schema
...@@ -139,3 +141,6 @@ class HasJWTSettings env where ...@@ -139,3 +141,6 @@ class HasJWTSettings env where
class HasRemoteTransferKeys env where class HasRemoteTransferKeys env where
remoteTransferKeys :: Getter env (RSA.PublicKey, RSA.PrivateKey) remoteTransferKeys :: Getter env (RSA.PublicKey, RSA.PrivateKey)
class HasManager env where
gargHttpManager :: Getter env HTTP.Manager
...@@ -185,6 +185,8 @@ $(deriveJSON (unPrefix "tr_") ''TableResult) ...@@ -185,6 +185,8 @@ $(deriveJSON (unPrefix "tr_") ''TableResult)
instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where
declareNamedSchema = wellNamedSchema "tr_" declareNamedSchema = wellNamedSchema "tr_"
instance NFData a => NFData (TableResult a) where
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
data Typed a b = data Typed a b =
Typed { _withType :: a Typed { _withType :: a
......
...@@ -57,7 +57,9 @@ instance Prelude.Show GargPassword where ...@@ -57,7 +57,9 @@ instance Prelude.Show GargPassword where
instance ToJSON GargPassword instance ToJSON GargPassword
instance FromJSON GargPassword instance FromJSON GargPassword
instance ToSchema GargPassword instance ToSchema GargPassword where
declareNamedSchema _ = pure $ NamedSchema (Just "GargPassword") passwordSchema
type Email = Text type Email = Text
type UsernameMaster = Username type UsernameMaster = Username
type UsernameSimple = Username type UsernameSimple = Username
......
...@@ -40,6 +40,8 @@ data NodeTree = NodeTree { _nt_name :: Text ...@@ -40,6 +40,8 @@ data NodeTree = NodeTree { _nt_name :: Text
, _nt_publish_policy :: Maybe NodePublishPolicy , _nt_publish_policy :: Maybe NodePublishPolicy
} deriving (Show, Read, Generic) } deriving (Show, Read, Generic)
instance NFData NodeTree where
instance Eq NodeTree where instance Eq NodeTree where
(==) d1 d2 = _nt_id d1 == _nt_id d2 (==) d1 d2 = _nt_id d1 == _nt_id d2
...@@ -56,6 +58,7 @@ type TypeId = Int ...@@ -56,6 +58,7 @@ type TypeId = Int
data ListType = CandidateTerm | StopTerm | MapTerm data ListType = CandidateTerm | StopTerm | MapTerm
deriving (Generic, Eq, Ord, Show, Read, Enum, Bounded, ToExpr) deriving (Generic, Eq, Ord, Show, Read, Enum, Bounded, ToExpr)
instance NFData ListType where
instance ToJSON ListType instance ToJSON ListType
instance FromJSON ListType instance FromJSON ListType
instance ToSchema ListType instance ToSchema ListType
...@@ -115,6 +118,8 @@ fromListTypeId = flip Bimap.lookupR listTypeIds ...@@ -115,6 +118,8 @@ fromListTypeId = flip Bimap.lookupR listTypeIds
data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] } data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
deriving (Show, Read, Eq, Generic, Ord) deriving (Show, Read, Eq, Generic, Ord)
instance NFData a => NFData (Tree a) where
$(deriveJSON (unPrefix "_tn_") ''Tree) $(deriveJSON (unPrefix "_tn_") ''Tree)
instance (Typeable a, ToSchema a) => ToSchema (Tree a) where instance (Typeable a, ToSchema a) => ToSchema (Tree a) where
......
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-| {-|
Module : Gargantext.Core.Worker.Types Module : Gargantext.Core.Worker.Types
Description : Some useful worker types Description : Some useful worker types
...@@ -36,4 +38,4 @@ instance FromJSON JobInfo where ...@@ -36,4 +38,4 @@ instance FromJSON JobInfo where
instance ToJSON JobInfo where instance ToJSON JobInfo where
toJSON (JobInfo { .. }) = object [ "message_id" .= _ji_message_id toJSON (JobInfo { .. }) = object [ "message_id" .= _ji_message_id
, "node_id" .= _ji_mNode_id ] , "node_id" .= _ji_mNode_id ]
instance NFData JobInfo
...@@ -21,6 +21,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude ...@@ -21,6 +21,8 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude
newtype HyperdataAny = HyperdataAny Object newtype HyperdataAny = HyperdataAny Object
deriving (Show, Generic, ToJSON, FromJSON) deriving (Show, Generic, ToJSON, FromJSON)
instance NFData HyperdataAny
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Instances -- Instances
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -39,6 +39,8 @@ data HyperdataContact = ...@@ -39,6 +39,8 @@ data HyperdataContact =
instance GQLType HyperdataContact where instance GQLType HyperdataContact where
directives _ = typeDirective DropNamespace { dropNamespace = "_hc_" } directives _ = typeDirective DropNamespace { dropNamespace = "_hc_" }
instance NFData HyperdataContact where
instance HasText HyperdataContact instance HasText HyperdataContact
where where
hasText = undefined hasText = undefined
...@@ -83,7 +85,7 @@ arbitraryHyperdataContact = ...@@ -83,7 +85,7 @@ arbitraryHyperdataContact =
, _hc_lastValidation = Nothing } , _hc_lastValidation = Nothing }
data ContactWho = data ContactWho =
ContactWho { _cw_id :: Maybe Text ContactWho { _cw_id :: Maybe Text
, _cw_firstName :: Maybe Text , _cw_firstName :: Maybe Text
, _cw_lastName :: Maybe Text , _cw_lastName :: Maybe Text
...@@ -95,6 +97,8 @@ data ContactWho = ...@@ -95,6 +97,8 @@ data ContactWho =
instance GQLType ContactWho where instance GQLType ContactWho where
directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" } directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
instance NFData ContactWho where
type FirstName = Text type FirstName = Text
type LastName = Text type LastName = Text
...@@ -113,15 +117,11 @@ contactWho fn ln = ...@@ -113,15 +117,11 @@ contactWho fn ln =
data ContactWhere = data ContactWhere =
ContactWhere { _cw_organization :: [Text] ContactWhere { _cw_organization :: [Text]
, _cw_labTeamDepts :: [Text] , _cw_labTeamDepts :: [Text]
, _cw_role :: Maybe Text , _cw_role :: Maybe Text
, _cw_office :: Maybe Text , _cw_office :: Maybe Text
, _cw_country :: Maybe Text , _cw_country :: Maybe Text
, _cw_city :: Maybe Text , _cw_city :: Maybe Text
, _cw_touch :: Maybe ContactTouch , _cw_touch :: Maybe ContactTouch
, _cw_entry :: Maybe NUTCTime , _cw_entry :: Maybe NUTCTime
, _cw_exit :: Maybe NUTCTime , _cw_exit :: Maybe NUTCTime
} deriving (Eq, Show, Generic) } deriving (Eq, Show, Generic)
...@@ -129,6 +129,8 @@ data ContactWhere = ...@@ -129,6 +129,8 @@ data ContactWhere =
instance GQLType ContactWhere where instance GQLType ContactWhere where
directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" } directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
instance NFData ContactWhere where
defaultContactWhere :: ContactWhere defaultContactWhere :: ContactWhere
defaultContactWhere = defaultContactWhere =
ContactWhere ContactWhere
...@@ -151,6 +153,8 @@ data ContactTouch = ...@@ -151,6 +153,8 @@ data ContactTouch =
instance GQLType ContactTouch where instance GQLType ContactTouch where
directives _ = typeDirective DropNamespace { dropNamespace = "_ct_" } directives _ = typeDirective DropNamespace { dropNamespace = "_ct_" }
instance NFData ContactTouch where
defaultContactTouch :: ContactTouch defaultContactTouch :: ContactTouch
defaultContactTouch = defaultContactTouch =
ContactTouch ContactTouch
......
...@@ -40,6 +40,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T ...@@ -40,6 +40,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T
} }
deriving (Show, Generic) deriving (Show, Generic)
instance NFData HyperdataDocument
instance HasText HyperdataDocument instance HasText HyperdataDocument
where where
......
...@@ -40,6 +40,8 @@ data HyperdataUser = ...@@ -40,6 +40,8 @@ data HyperdataUser =
instance GQLType HyperdataUser where instance GQLType HyperdataUser where
directives _ = typeDirective DropNamespace { dropNamespace = "_hu_" } directives _ = typeDirective DropNamespace { dropNamespace = "_hu_" }
instance NFData HyperdataUser where
data HyperdataPrivate = data HyperdataPrivate =
HyperdataPrivate { _hpr_password :: !Text HyperdataPrivate { _hpr_password :: !Text
, _hpr_lang :: !Lang , _hpr_lang :: !Lang
...@@ -49,6 +51,8 @@ data HyperdataPrivate = ...@@ -49,6 +51,8 @@ data HyperdataPrivate =
instance GQLType HyperdataPrivate where instance GQLType HyperdataPrivate where
directives _ = typeDirective DropNamespace { dropNamespace = "_hpr_" } directives _ = typeDirective DropNamespace { dropNamespace = "_hpr_" }
instance NFData HyperdataPrivate where
data HyperdataPublic = data HyperdataPublic =
HyperdataPublic { _hpu_pseudo :: !Text HyperdataPublic { _hpu_pseudo :: !Text
...@@ -59,6 +63,8 @@ data HyperdataPublic = ...@@ -59,6 +63,8 @@ data HyperdataPublic =
instance GQLType HyperdataPublic where instance GQLType HyperdataPublic where
directives _ = typeDirective DropNamespace { dropNamespace = "_hpu_" } directives _ = typeDirective DropNamespace { dropNamespace = "_hpu_" }
instance NFData HyperdataPublic where
-- | Default -- | Default
defaultHyperdataUser :: HyperdataUser defaultHyperdataUser :: HyperdataUser
defaultHyperdataUser = defaultHyperdataUser =
......
...@@ -69,6 +69,8 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int } ...@@ -69,6 +69,8 @@ newtype UserId = UnsafeMkUserId { _UserId :: Int }
deriving stock (Show, Eq, Ord, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving newtype (ToSchema, ToJSON, FromJSON, FromField, ToField, Hashable) deriving newtype (ToSchema, ToJSON, FromJSON, FromField, ToField, Hashable)
instance NFData UserId where
-- The 'UserId' is isomprohic to an 'Int'. -- The 'UserId' is isomprohic to an 'Int'.
instance GQLType UserId where instance GQLType UserId where
type KIND UserId = SCALAR type KIND UserId = SCALAR
...@@ -257,6 +259,8 @@ newtype NodeId = UnsafeMkNodeId { _NodeId :: Int } ...@@ -257,6 +259,8 @@ newtype NodeId = UnsafeMkNodeId { _NodeId :: Int }
deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField) deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
deriving anyclass (ToExpr) deriving anyclass (ToExpr)
instance NFData NodeId where
instance ResourceId NodeId where instance ResourceId NodeId where
isPositive = (> 0) . _NodeId isPositive = (> 0) . _NodeId
...@@ -291,6 +295,7 @@ newtype ContextId = UnsafeMkContextId { _ContextId :: Int } ...@@ -291,6 +295,7 @@ newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
deriving FromField via NodeId deriving FromField via NodeId
instance ToParamSchema ContextId instance ToParamSchema ContextId
instance NFData ContextId
instance Arbitrary ContextId where instance Arbitrary ContextId where
arbitrary = UnsafeMkContextId . getPositive <$> arbitrary arbitrary = UnsafeMkContextId . getPositive <$> arbitrary
...@@ -443,6 +448,7 @@ data NodeType ...@@ -443,6 +448,7 @@ data NodeType
deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum) deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
instance GQLType NodeType instance GQLType NodeType
instance NFData NodeType where
-- /NOTE/ (adn) For backward-compatibility reasons, we keep the format for ToJSON/FromJSON similar -- /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 -- to what 'Show/Read' would generate, but we otherwise generate \"by hand\" the mapping between a
...@@ -650,6 +656,8 @@ data NodePublishPolicy ...@@ -650,6 +656,8 @@ data NodePublishPolicy
| NPP_publish_edits_only_owner_or_super | NPP_publish_edits_only_owner_or_super
deriving (Show, Read, Generic, Eq, Ord, Enum, Bounded) deriving (Show, Read, Generic, Eq, Ord, Enum, Bounded)
instance NFData NodePublishPolicy where
instance HasDBid NodePublishPolicy where instance HasDBid NodePublishPolicy where
toDBid = \case toDBid = \case
NPP_publish_no_edits_allowed NPP_publish_no_edits_allowed
......
...@@ -56,6 +56,8 @@ data Facet id date hyperdata score = ...@@ -56,6 +56,8 @@ data Facet id date hyperdata score =
} deriving (Show, Generic) } 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 { data Pair i l = Pair {
......
...@@ -19,6 +19,7 @@ module Gargantext.Database.Schema.Node where ...@@ -19,6 +19,7 @@ module Gargantext.Database.Schema.Node where
import Control.Lens hiding (elements, (&)) import Control.Lens hiding (elements, (&))
import Gargantext.Database.Schema.Prelude import Gargantext.Database.Schema.Prelude
import Prelude hiding (null, id, map, sum) import Prelude hiding (null, id, map, sum)
import Gargantext.Prelude (NFData(..))
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Main polymorphic Node definition -- Main polymorphic Node definition
...@@ -43,6 +44,9 @@ data NodePoly id ...@@ -43,6 +44,9 @@ data NodePoly id
, _node_hyperdata :: !hyperdata , _node_hyperdata :: !hyperdata
} deriving (Show, Generic) } 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 -- Automatic instances derivation
$(deriveJSON (unPrefix "_node_") ''NodePoly) $(deriveJSON (unPrefix "_node_") ''NodePoly)
......
...@@ -7,16 +7,17 @@ ...@@ -7,16 +7,17 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Gargantext.Orphans.OpenAPI where module Gargantext.Orphans.OpenAPI where
import Conduit qualified as C
import Control.Lens import Control.Lens
import Data.HashMap.Strict.InsOrd qualified as HM import Data.HashMap.Strict.InsOrd qualified as HM
import Data.OpenApi as OpenAPI hiding (Header, Server) import Data.OpenApi as OpenAPI hiding (Header, Server)
import Data.OpenApi.Declare import Data.OpenApi.Declare
import Data.Swagger.Declare qualified as SwaggerDeclare
import Data.Swagger.Internal qualified as Swagger import Data.Swagger.Internal qualified as Swagger
import Data.Swagger qualified as Swagger import Data.Swagger qualified as Swagger
import Data.Text qualified as T import Data.Text qualified as T
import Data.Typeable import Data.Typeable
import Prelude import Prelude
import qualified Data.Swagger.Declare as SwaggerDeclare
import Servant.API import Servant.API
import Servant.Auth import Servant.Auth
import Servant.OpenApi import Servant.OpenApi
...@@ -85,6 +86,9 @@ class SwaggerConvertible a b where ...@@ -85,6 +86,9 @@ class SwaggerConvertible a b where
-- Instances -- Instances
-- --
instance Typeable b => ToSchema (C.ConduitT () b IO ()) where
declareNamedSchema _ = pure $ NamedSchema Nothing binarySchema
instance SwaggerConvertible OpenAPI.Discriminator T.Text where instance SwaggerConvertible OpenAPI.Discriminator T.Text where
swagConv = iso OpenAPI._discriminatorPropertyName convertDiscriminator swagConv = iso OpenAPI._discriminatorPropertyName convertDiscriminator
where where
......
...@@ -35,6 +35,7 @@ import Test.QuickCheck hiding (label) ...@@ -35,6 +35,7 @@ import Test.QuickCheck hiding (label)
newtype NUTCTime = NUTCTime UTCTime newtype NUTCTime = NUTCTime UTCTime
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
deriving newtype NFData
instance DecodeScalar NUTCTime where instance DecodeScalar NUTCTime where
decodeScalar (DMT.String x) = case (readEither $ T.unpack x) of decodeScalar (DMT.String x) = case (readEither $ T.unpack x) of
Right r -> pure $ NUTCTime r Right r -> pure $ NUTCTime r
......
...@@ -25,7 +25,7 @@ import Network.HTTP.Client hiding (Proxy) ...@@ -25,7 +25,7 @@ import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Types.Status (status403) import Network.HTTP.Types.Status (status403)
import Prelude qualified import Prelude qualified
import Servant.Auth.Client () import Servant.Auth.Client ()
import Servant.Client import Servant.Client.Streaming
import Servant.Client.Core.Response qualified as SR import Servant.Client.Core.Response qualified as SR
import Servant.Client.Generic (genericClient) import Servant.Client.Generic (genericClient)
import Test.API.Routes (auth_api) import Test.API.Routes (auth_api)
......
...@@ -16,7 +16,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser) ...@@ -16,7 +16,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Prelude hiding (get) import Gargantext.Prelude hiding (get)
import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client hiding (Proxy)
import Servant.Auth.Client () import Servant.Auth.Client ()
import Servant.Client import Servant.Client.Streaming
import Servant.Client.Generic (genericClient) import Servant.Client.Generic (genericClient)
import Test.API.Prelude import Test.API.Prelude
import Test.API.Private.Move qualified as Move import Test.API.Private.Move qualified as Move
......
...@@ -11,7 +11,7 @@ import Gargantext.Core.Types ...@@ -11,7 +11,7 @@ import Gargantext.Core.Types
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..)) import Gargantext.Database.Query.Table.NodeNode (SourceId(..), TargetId(..))
import Gargantext.Prelude import Gargantext.Prelude
import Servant.Client import Servant.Client.Streaming
import Test.API.Prelude import Test.API.Prelude
import Test.API.Routes import Test.API.Routes
import Test.API.Setup import Test.API.Setup
......
...@@ -18,7 +18,7 @@ import Gargantext.Core.Types.Individu ...@@ -18,7 +18,7 @@ import Gargantext.Core.Types.Individu
import Gargantext.Prelude import Gargantext.Prelude
import Prelude (fail) import Prelude (fail)
import Servant.Auth.Client qualified as SC import Servant.Auth.Client qualified as SC
import Servant.Client import Servant.Client.Streaming
import Test.API.Prelude (newCorpusForUser) import Test.API.Prelude (newCorpusForUser)
import Test.API.Routes import Test.API.Routes
import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort) import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort)
......
...@@ -11,7 +11,7 @@ import Gargantext.Core.Types ...@@ -11,7 +11,7 @@ import Gargantext.Core.Types
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Query.Facet qualified as Facet import Gargantext.Database.Query.Facet qualified as Facet
import Gargantext.Prelude import Gargantext.Prelude
import Servant.Client import Servant.Client.Streaming
import Test.API.Prelude (checkEither) import Test.API.Prelude (checkEither)
import Test.API.Routes import Test.API.Routes
import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort) import Test.API.Setup (SpecContext(..), dbEnvSetup, withTestDBAndPort)
......
...@@ -37,6 +37,7 @@ import Gargantext.API.Errors ...@@ -37,6 +37,7 @@ import Gargantext.API.Errors
import Gargantext.API.HashedResponse (HashedResponse) import Gargantext.API.HashedResponse (HashedResponse)
import Gargantext.API.Ngrams.List.Types (WithJsonFile, WithTextFile) import Gargantext.API.Ngrams.List.Types (WithJsonFile, WithTextFile)
import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount ) 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
import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp) import Gargantext.API.Routes.Named.List (updateListJSONEp, updateListTSVEp)
import Gargantext.API.Routes.Named.Node hiding (treeAPI) import Gargantext.API.Routes.Named.Node hiding (treeAPI)
...@@ -59,19 +60,10 @@ import Network.HTTP.Types qualified as H ...@@ -59,19 +60,10 @@ import Network.HTTP.Types qualified as H
import Network.Wai.Handler.Warp (Port) import Network.Wai.Handler.Warp (Port)
import Servant.API.WebSocket qualified as WS import Servant.API.WebSocket qualified as WS
import Servant.Auth.Client qualified as S import Servant.Auth.Client qualified as S
import Servant.Client (ClientM)
import Servant.Client.Core (RunClient, HasClient(..), Request) import Servant.Client.Core (RunClient, HasClient(..), Request)
import Servant.Client.Generic ( genericClient, AsClientT ) import Servant.Client.Generic ( genericClient, AsClientT )
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)
-- This is for requests made by http.client directly to hand-crafted URLs. -- This is for requests made by http.client directly to hand-crafted URLs.
...@@ -85,12 +77,6 @@ mkUrl _port urlPiece = ...@@ -85,12 +77,6 @@ mkUrl _port urlPiece =
gqlUrl :: ByteString gqlUrl :: ByteString
gqlUrl = "/gql" 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 -- This is for Servant.Client requests
auth_api :: AuthRequest -> ClientM AuthResponse auth_api :: AuthRequest -> ClientM AuthResponse
auth_api = clientRoutes & apiWithCustomErrorScheme auth_api = clientRoutes & apiWithCustomErrorScheme
......
...@@ -62,7 +62,7 @@ import Gargantext.Database.Query.Facet qualified as Facet ...@@ -62,7 +62,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
import Gargantext.Prelude hiding (get) import Gargantext.Prelude hiding (get)
import Network.Wai.Handler.Warp qualified as Wai import Network.Wai.Handler.Warp qualified as Wai
import Paths_gargantext (getDataFileName) import Paths_gargantext (getDataFileName)
import Servant.Client import Servant.Client.Streaming
import System.FilePath import System.FilePath
import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser) 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) 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)
......
...@@ -13,6 +13,7 @@ import Gargantext.API.Errors ...@@ -13,6 +13,7 @@ import Gargantext.API.Errors
import Gargantext.API.Node.Corpus.Types import Gargantext.API.Node.Corpus.Types
import Gargantext.API.Node.Types import Gargantext.API.Node.Types
import Gargantext.API.Routes.Named.Publish (PublishRequest) import Gargantext.API.Routes.Named.Publish (PublishRequest)
import Gargantext.API.Routes.Named.Remote
import Gargantext.API.Viz.Types import Gargantext.API.Viz.Types
import Gargantext.Core.Types.Phylo import Gargantext.Core.Types.Phylo
import Gargantext.Core.Viz.Phylo qualified as VizPhylo import Gargantext.Core.Viz.Phylo qualified as VizPhylo
...@@ -56,6 +57,7 @@ tests = testGroup "JSON" [ ...@@ -56,6 +57,7 @@ tests = testGroup "JSON" [
, testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield) , testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield)
, testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery) , testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery)
, testProperty "PublishRequest roundtrips" (jsonRoundtrip @PublishRequest) , testProperty "PublishRequest roundtrips" (jsonRoundtrip @PublishRequest)
, testProperty "RemoteExportRequest roundtrips" (jsonRoundtrip @RemoteExportRequest)
, testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip , testProperty "FrontendError roundtrips" jsonFrontendErrorRoundtrip
, testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode)) , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
, testProperty "NodeType roundtrips" (jsonEnumRoundtrip (Dict @_ @NodeType)) , testProperty "NodeType roundtrips" (jsonEnumRoundtrip (Dict @_ @NodeType))
......
...@@ -8,7 +8,7 @@ import Network.HTTP.Client ...@@ -8,7 +8,7 @@ import Network.HTTP.Client
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Prelude import Prelude
import Servant.Auth.Client (Token(..)) import Servant.Auth.Client (Token(..))
import Servant.Client import Servant.Client.Streaming
import Servant.Client.Generic (genericClient) import Servant.Client.Generic (genericClient)
import Test.API.Setup (setupEnvironment, withBackendServerAndProxy, createAliceAndBob) import Test.API.Setup (setupEnvironment, withBackendServerAndProxy, createAliceAndBob)
import Test.Hspec import Test.Hspec
......
...@@ -61,7 +61,7 @@ import Network.Wai.Handler.Warp (Port) ...@@ -61,7 +61,7 @@ import Network.Wai.Handler.Warp (Port)
import Network.Wai.Test (SResponse(..)) import Network.Wai.Test (SResponse(..))
import Network.WebSockets qualified as WS import Network.WebSockets qualified as WS
import Prelude qualified 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 (BaseUrl)
import Servant.Client.Core.Request qualified as Client import Servant.Client.Core.Request qualified as Client
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment