Commit 5a8782a6 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

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

parent 1f875bee
Pipeline #7072 failed with stages
in 39 minutes and 16 seconds
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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_
......
......@@ -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
......
{-# 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
......@@ -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
......
......@@ -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
}
{-# 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"
}
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -40,6 +40,7 @@ data HyperdataDocument = HyperdataDocument { _hd_bdd :: !(Maybe T
}
deriving (Show, Generic)
instance NFData HyperdataDocument
instance HasText HyperdataDocument
where
......
......@@ -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
......
......@@ -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 {
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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(..))
......
......@@ -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)
......
......@@ -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))
......
......@@ -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
......
......@@ -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)
......
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