From e578bc9c01962c7370100d4e911b48b326ba450b Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli <alfredo@well-typed.com> Date: Tue, 28 May 2024 11:53:07 +0200 Subject: [PATCH] Derive generic clients --- cabal.project | 4 +- gargantext.cabal | 4 +- src/Gargantext/API/Admin/Auth.hs | 11 +-- .../API/Admin/Orchestrator/Types.hs | 5 +- src/Gargantext/API/Auth/PolicyCheck.hs | 7 ++ src/Gargantext/API/Ngrams/List.hs | 5 +- src/Gargantext/API/Ngrams/Types.hs | 11 ++- src/Gargantext/API/Node.hs | 2 +- src/Gargantext/API/Node/Contact.hs | 3 +- src/Gargantext/API/Node/Corpus/Annuaire.hs | 11 --- src/Gargantext/API/Node/Corpus/New.hs | 27 ------ .../API/Node/Document/Export/Types.hs | 5 +- src/Gargantext/API/Node/DocumentUpload.hs | 3 +- .../API/Node/DocumentsFromWriteNodes.hs | 3 +- src/Gargantext/API/Node/File.hs | 54 +++--------- src/Gargantext/API/Node/File/Types.hs | 36 ++++++++ src/Gargantext/API/Node/FrameCalcUpload.hs | 3 +- src/Gargantext/API/Node/New.hs | 11 +-- src/Gargantext/API/Node/Update.hs | 3 +- src/Gargantext/API/Routes.hs | 15 ++-- src/Gargantext/API/Routes/Named.hs | 4 +- src/Gargantext/API/Routes/Named/Annuaire.hs | 2 +- src/Gargantext/API/Routes/Named/Contact.hs | 2 +- src/Gargantext/API/Routes/Named/Corpus.hs | 4 +- src/Gargantext/API/Routes/Named/Document.hs | 4 +- src/Gargantext/API/Routes/Named/File.hs | 4 +- src/Gargantext/API/Routes/Named/FrameCalc.hs | 2 +- src/Gargantext/API/Routes/Named/List.hs | 4 +- src/Gargantext/API/Routes/Named/Node.hs | 4 +- src/Gargantext/API/Routes/Named/Table.hs | 2 +- src/Gargantext/API/Routes/Types.hs | 11 ++- src/Gargantext/API/Server/Named/Ngrams.hs | 3 +- src/Gargantext/API/Types.hs | 20 +++-- stack.yaml | 4 +- test/Test/API/Authentication.hs | 2 +- test/Test/API/Routes.hs | 82 +++++++++++++++---- test/Test/API/Setup.hs | 2 +- test/Test/API/UpdateList.hs | 10 +-- test/Test/Utils.hs | 2 +- 39 files changed, 217 insertions(+), 174 deletions(-) create mode 100644 src/Gargantext/API/Node/File/Types.hs diff --git a/cabal.project b/cabal.project index 69c814bc..1ff19fbf 100644 --- a/cabal.project +++ b/cabal.project @@ -51,8 +51,8 @@ source-repository-package source-repository-package type: git - location: https://github.com/alpmestan/servant-job.git - tag: b4182487cfe479777c11ca19f3c0d47840b376f6 + location: https://github.com/adinapoli/servant-job.git + tag: 74a3296dfe1f0c4a3ade91336dcc689330e84156 source-repository-package type: git diff --git a/gargantext.cabal b/gargantext.cabal index dd9c1a79..7099aa21 100644 --- a/gargantext.cabal +++ b/gargantext.cabal @@ -133,6 +133,7 @@ library Gargantext.API.Node.Corpus.Types Gargantext.API.Node.Corpus.Update Gargantext.API.Node.File + Gargantext.API.Node.File.Types Gargantext.API.Node.Share Gargantext.API.Node.Share.Types Gargantext.API.Node.ShareURL @@ -162,6 +163,7 @@ library Gargantext.API.Routes.Named.Tree Gargantext.API.Routes.Named.Viz Gargantext.API.Routes.Types + Gargantext.API.Types Gargantext.API.Viz.Types Gargantext.Core Gargantext.Core.Mail.Types @@ -327,7 +329,6 @@ library Gargantext.API.Table Gargantext.API.Table.Types Gargantext.API.ThrowAll - Gargantext.API.Types Gargantext.Core.Ext.IMT Gargantext.Core.Ext.IMTUser Gargantext.Core.Flow.Ngrams @@ -642,6 +643,7 @@ library , servant-server >= 0.18.3 && < 0.20 , servant-swagger >= 1.2 , servant-swagger-ui ^>= 0.3.5.3.5.0 + , servant-swagger-ui-core >= 0.3.5 , servant-xml-conduit >= 0.1.0.4 , simple-reflect ^>= 0.3.3 , singletons ^>= 2.7 diff --git a/src/Gargantext/API/Admin/Auth.hs b/src/Gargantext/API/Admin/Auth.hs index 86011f87..48dc3b8c 100644 --- a/src/Gargantext/API/Admin/Auth.hs +++ b/src/Gargantext/API/Admin/Auth.hs @@ -50,8 +50,10 @@ import Data.UUID (UUID, fromText, toText) import Data.UUID.V4 (nextRandom) import Gargantext.API.Admin.Auth.Types import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Admin.Types import Gargantext.API.Auth.PolicyCheck +import Gargantext.API.Errors import Gargantext.API.Prelude (authenticationError, HasServerError, GargServerC, _ServerError, GargM, IsGargServer) import Gargantext.Core.Mail (MailModel(..), mail) import Gargantext.Core.Mail.Types (mailSettings) @@ -59,8 +61,8 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..)) import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.User.New (guessUserName) import Gargantext.Database.Admin.Types.Node (NodeId(..)) -import Gargantext.Database.Prelude (Cmd', CmdCommon, DbCmd') import Gargantext.Database.Admin.Types.Node (UserId) +import Gargantext.Database.Prelude (Cmd', CmdCommon, DbCmd') import Gargantext.Database.Query.Table.User import Gargantext.Database.Query.Tree (isDescendantOf, isIn) import Gargantext.Database.Query.Tree.Root (getRoot) @@ -70,11 +72,10 @@ import Gargantext.Prelude.Crypto.Auth qualified as Auth import Gargantext.Prelude.Crypto.Pass.User (gargPass) import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..)) import Servant +import Servant.API.Generic () import Servant.Auth.Server -import Gargantext.API.Errors -import qualified Gargantext.API.Routes.Named as Named import Servant.Server.Generic -import Servant.API.Generic () +import qualified Gargantext.API.Routes.Named as Named --------------------------------------------------- @@ -325,7 +326,7 @@ generateForgotPasswordUUID = do -- request, because the delay in email sending etc won't reveal to -- malicious users emails of our users in the db forgotPasswordAsync :: Named.ForgotPasswordAsyncAPI (AsServerT (GargM Env BackendInternalError)) -forgotPasswordAsync = Named.ForgotPasswordAsyncAPI $ +forgotPasswordAsync = Named.ForgotPasswordAsyncAPI $ AsyncJobs $ serveJobsAPI ForgotPasswordJob $ \jHandle p -> forgotPasswordAsync' p jHandle forgotPasswordAsync' :: (FlowCmdM env err m, MonadJobStatus m) diff --git a/src/Gargantext/API/Admin/Orchestrator/Types.hs b/src/Gargantext/API/Admin/Orchestrator/Types.hs index 899c3b24..1aa6a19c 100644 --- a/src/Gargantext/API/Admin/Orchestrator/Types.hs +++ b/src/Gargantext/API/Admin/Orchestrator/Types.hs @@ -136,5 +136,6 @@ type ScrapersEnv = JobEnv JobLog JobLog type ScraperAPI = AsyncJobsAPI JobLog ScraperInput JobLog ------------------------------------------------------------------------ -type AsyncJobs event ctI input output = - AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output +data AsyncJobs event ctI input output mode = AsyncJobs + { asyncJobsAPI' :: mode :- AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output } + deriving Generic diff --git a/src/Gargantext/API/Auth/PolicyCheck.hs b/src/Gargantext/API/Auth/PolicyCheck.hs index f4548820..515302d7 100644 --- a/src/Gargantext/API/Auth/PolicyCheck.hs +++ b/src/Gargantext/API/Auth/PolicyCheck.hs @@ -39,6 +39,7 @@ import Servant.Ekg import Servant.Server.Internal.Delayed import Servant.Server.Internal.DelayedIO import qualified Servant.Swagger as Swagger +import Servant.Client.Core ------------------------------------------------------------------------------- -- Types @@ -196,6 +197,12 @@ instance HasEndpoint sub => HasEndpoint (PolicyChecked sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub) enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) +instance HasClient m sub => HasClient m (PolicyChecked sub) where + type Client m (PolicyChecked sub) = AccessPolicyManager -> Client m sub + clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req + + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl + ------------------------------------------------------------------------------- -- Utility functions ------------------------------------------------------------------------------- diff --git a/src/Gargantext/API/Ngrams/List.hs b/src/Gargantext/API/Ngrams/List.hs index c8149b16..50b908ce 100644 --- a/src/Gargantext/API/Ngrams/List.hs +++ b/src/Gargantext/API/Ngrams/List.hs @@ -28,6 +28,7 @@ import Data.Text (concat, pack, splitOn) import Data.Vector (Vector) import Data.Vector qualified as Vec import Gargantext.API.Admin.EnvTypes (Env, GargJob(..)) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Errors.Types (BackendInternalError) import Gargantext.API.Ngrams (setListNgrams) import Gargantext.API.Ngrams.List.Types @@ -106,7 +107,7 @@ getCsv lId = do ------------------------------------------------------------------------ jsonPostAsync :: Named.JSONAPI (AsServerT (GargM Env BackendInternalError)) -jsonPostAsync = Named.JSONAPI $ \lId -> +jsonPostAsync = Named.JSONAPI $ \lId -> AsyncJobs $ serveJobsAPI UpdateNgramsListJobJSON $ \jHandle f -> postAsyncJSON lId (_wjf_data f) jHandle @@ -147,7 +148,7 @@ csvAPI = csvPostAsync ------------------------------------------------------------------------ csvPostAsync :: Named.CSVAPI (AsServerT (GargM Env BackendInternalError)) -csvPostAsync = Named.CSVAPI $ \lId -> +csvPostAsync = Named.CSVAPI $ \lId -> AsyncJobs $ serveJobsAPI UpdateNgramsListJobCSV $ \jHandle f -> do case ngramsListFromCSVData (_wtf_data f) of Left err -> serverError $ err500 { errReasonPhrase = err } diff --git a/src/Gargantext/API/Ngrams/Types.hs b/src/Gargantext/API/Ngrams/Types.hs index 5287aef3..7e5dceb4 100644 --- a/src/Gargantext/API/Ngrams/Types.hs +++ b/src/Gargantext/API/Ngrams/Types.hs @@ -49,7 +49,7 @@ import Gargantext.Prelude hiding (IsString, hash, from, replace, to) import Gargantext.Prelude.Crypto.Hash (IsHashable(..)) import Gargantext.Utils.Servant (CSV, ZIP) import Gargantext.Utils.Zip (zipContentsPure) -import Servant ( FromHttpApiData(parseUrlPiece), ToHttpApiData(toUrlPiece), Required, Strict, QueryParam', MimeRender(.. )) +import Servant ( FromHttpApiData(parseUrlPiece), ToHttpApiData(toUrlPiece), Required, Strict, QueryParam', MimeRender(.. ), MimeUnrender(..)) import Servant.Job.Utils (jsonOptions) import Test.QuickCheck (elements, frequency) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) @@ -94,7 +94,7 @@ instance ToJSONKey TabType where toJSONKey = genericToJSONKey defaultJSONKeyOptions newtype MSet a = MSet (Map a ()) - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Show, Read, Generic) deriving newtype (Arbitrary, Semigroup, Monoid) deriving anyclass (ToExpr) @@ -128,7 +128,7 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where ------------------------------------------------------------------------ newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text } - deriving (Ord, Eq, Show, Generic) + deriving (Ord, Eq, Show, Read, Generic) deriving newtype (ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData, FromField, ToField) deriving anyclass (ToExpr) instance IsHashable NgramsTerm where @@ -159,7 +159,7 @@ data NgramsRepoElement = NgramsRepoElement , _nre_parent :: !(Maybe NgramsTerm) , _nre_children :: !(MSet NgramsTerm) } - deriving (Ord, Eq, Show, Generic) + deriving (Ord, Eq, Show, Read, Generic) deriveJSON (unPrefix "_nre_") ''NgramsRepoElement -- TODO -- if ngrams & not size => size @@ -811,6 +811,9 @@ instance MimeRender ZIP NgramsListZIP where mimeRender _ nlz@(NgramsListZIP { .. }) = zipContentsPure (T.unpack $ nlzFileName nlz) (encode _nlz_nl) +instance MimeUnrender ZIP NgramsListZIP where + mimeUnrender _ _ = Left "mimeUnrender for NgramsListZIP not supported" + -- diff --git a/src/Gargantext/API/Node.hs b/src/Gargantext/API/Node.hs index 00e8483a..0f935eea 100644 --- a/src/Gargantext/API/Node.hs +++ b/src/Gargantext/API/Node.hs @@ -258,7 +258,7 @@ genericNodeAPI' _ authenticatedUser targetNode = Named.NodeAPI , moveAPI = Named.MoveAPI $ moveNode userRootId targetNode , unpublishEp = Share.unPublish targetNode , fileAPI = Named.FileAPI $ fileApi targetNode - , fileAsyncAPI = Named.FileAsyncAPI $ fileAsyncApi authenticatedUser targetNode + , fileAsyncAPI = fileAsyncApi authenticatedUser targetNode , dfwnAPI = DFWN.api authenticatedUser targetNode , documentUploadAPI = DocumentUpload.api targetNode } diff --git a/src/Gargantext/API/Node/Contact.hs b/src/Gargantext/API/Node/Contact.hs index 4ee93eba..df059cc7 100644 --- a/src/Gargantext/API/Node/Contact.hs +++ b/src/Gargantext/API/Node/Contact.hs @@ -23,6 +23,7 @@ module Gargantext.API.Node.Contact import Conduit ( yield ) import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser(AuthenticatedUser) ) import Gargantext.API.Admin.EnvTypes (Env, GargJob(..)) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Node ( nodeNodeAPI ) @@ -51,7 +52,7 @@ contactAPI authUser@(AuthenticatedUser userNodeId _userUserId) cid = Named.Conta ---------------------------------------------------------------------- api_async :: User -> NodeId -> Named.ContactAsyncAPI (AsServerT (GargM Env BackendInternalError)) -api_async u nId = Named.ContactAsyncAPI $ +api_async u nId = Named.ContactAsyncAPI $ AsyncJobs $ serveJobsAPI AddContactJob $ \jHandle p -> addContact u nId p jHandle diff --git a/src/Gargantext/API/Node/Corpus/Annuaire.hs b/src/Gargantext/API/Node/Corpus/Annuaire.hs index 53b99b73..3ea61550 100644 --- a/src/Gargantext/API/Node/Corpus/Annuaire.hs +++ b/src/Gargantext/API/Node/Corpus/Annuaire.hs @@ -17,7 +17,6 @@ module Gargantext.API.Node.Corpus.Annuaire import Control.Lens hiding (elements) import Data.Aeson import Data.Swagger -import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Node.Corpus.New.Types qualified as NewTypes import Gargantext.Core (Lang(..)) import Gargantext.Core.Utils.Prefix (unPrefixSwagger) @@ -51,16 +50,6 @@ instance ToJSON AnnuaireWithForm where instance ToSchema AnnuaireWithForm where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_") ------------------------------------------------------------------------- - -type AddWithForm = Summary "Add with FormUrlEncoded to annuaire endpoint" - :> "annuaire" - :> Capture "annuaire_id" AnnuaireId - :> "add" - :> "form" - :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] AnnuaireWithForm JobLog - ------------------------------------------------------------------------ addToAnnuaireWithForm :: (FlowCmdM env err m, MonadJobStatus m) => AnnuaireId diff --git a/src/Gargantext/API/Node/Corpus/New.hs b/src/Gargantext/API/Node/Corpus/New.hs index 509dec0b..9edb4578 100644 --- a/src/Gargantext/API/Node/Corpus/New.hs +++ b/src/Gargantext/API/Node/Corpus/New.hs @@ -28,7 +28,6 @@ import Data.Swagger ( ToSchema(..) ) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import EPO.API.Client.Types qualified as EPO -import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs) import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Ngrams (commitStatePatch, Versioned(..)) import Gargantext.API.Node.Corpus.New.Types ( FileFormat(..), FileType(..) ) @@ -61,7 +60,6 @@ import Gargantext.Prelude import Gargantext.Prelude.Config (gc_max_docs_parsers) import Gargantext.System.Logging ( logLocM, LogLevel(..) ) import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..)) -import Servant ( JSON, type (:>), FormUrlEncoded, Capture, Summary ) import Test.QuickCheck.Arbitrary (Arbitrary(..)) ------------------------------------------------------------------------ @@ -132,13 +130,6 @@ instance ToSchema ApiInfo info :: ApiInfo info = ApiInfo API.externalAPIs ------------------------------------------------------------------------- -type AddWithQuery = Summary "Add with Query to corpus endpoint" - :> "corpus" - :> Capture "corpus_id" CorpusId - :> "query" - :> AsyncJobs JobLog '[JSON] WithQuery JobLog - {- type AddWithFile = Summary "Add with MultipartData to corpus endpoint" :> "corpus" @@ -228,14 +219,6 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q $(logLocM) ERROR (T.pack $ show err) -- log the full error markFailed (Just err) jobHandle -type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint" - :> "corpus" - :> Capture "corpus_id" CorpusId - :> "add" - :> "form" - :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog - addToCorpusWithForm :: ( FlowCmdM env err m , MonadJobStatus m , HasNodeStoryImmediateSaver env @@ -342,16 +325,6 @@ addToCorpusWithFile cid input filetype logStatus = do } -} - - -type AddWithFile = Summary "Add with FileUrlEncoded to corpus endpoint" - :> "corpus" - :> Capture "corpus_id" CorpusId - :> "add" - :> "file" - :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog - addToCorpusWithFile :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m) => User -> CorpusId diff --git a/src/Gargantext/API/Node/Document/Export/Types.hs b/src/Gargantext/API/Node/Document/Export/Types.hs index 412737a7..abf95be7 100644 --- a/src/Gargantext/API/Node/Document/Export/Types.hs +++ b/src/Gargantext/API/Node/Document/Export/Types.hs @@ -27,7 +27,7 @@ import Gargantext.Database.Schema.Node (NodePoly(..)) import Gargantext.Utils.Servant (ZIP) import Gargantext.Utils.Zip (zipContentsPureWithLastModified) import Protolude -import Servant (MimeRender(..)) +import Servant (MimeRender(..), MimeUnrender(..)) -- | Document Export @@ -118,3 +118,6 @@ dezFileName (DocumentExportZIP { .. }) = "GarganText_DocsList-" <> show _dez_doc instance MimeRender ZIP DocumentExportZIP where mimeRender _ dexpz@(DocumentExportZIP { .. }) = zipContentsPureWithLastModified (T.unpack $ dezFileName dexpz) (encode _dez_dexp) _dez_last_modified + +instance MimeUnrender ZIP DocumentExportZIP where + mimeUnrender _ _ = Left "mimeUnrender for DocumentExportZIP not supported" diff --git a/src/Gargantext/API/Node/DocumentUpload.hs b/src/Gargantext/API/Node/DocumentUpload.hs index c280d264..51b4adc0 100644 --- a/src/Gargantext/API/Node/DocumentUpload.hs +++ b/src/Gargantext/API/Node/DocumentUpload.hs @@ -19,6 +19,7 @@ module Gargantext.API.Node.DocumentUpload where import Control.Lens (view) import Data.Text qualified as T import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) +import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Node.DocumentUpload.Types import Gargantext.API.Prelude ( GargM ) @@ -39,7 +40,7 @@ import Servant.Server.Generic (AsServerT) api :: NodeId -> Named.DocumentUploadAPI (AsServerT (GargM Env BackendInternalError)) -api nId = Named.DocumentUploadAPI $ +api nId = Named.DocumentUploadAPI $ AsyncJobs $ serveJobsAPI UploadDocumentJob $ \jHandle q -> do documentUploadAsync nId q jHandle diff --git a/src/Gargantext/API/Node/DocumentsFromWriteNodes.hs b/src/Gargantext/API/Node/DocumentsFromWriteNodes.hs index 654b9c05..08e9060f 100644 --- a/src/Gargantext/API/Node/DocumentsFromWriteNodes.hs +++ b/src/Gargantext/API/Node/DocumentsFromWriteNodes.hs @@ -21,6 +21,7 @@ import Data.List qualified as List import Data.Text qualified as T import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser, auth_node_id, auth_user_id ) import Gargantext.API.Admin.EnvTypes (Env, GargJob(..)) +import Gargantext.API.Admin.Orchestrator.Types import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Ngrams (commitStatePatch, Versioned(..)) @@ -50,7 +51,7 @@ api :: AuthenticatedUser -- ^ The logged-in user -> NodeId -> Named.DocumentsFromWriteNodesAPI (AsServerT (GargM Env BackendInternalError)) -api authenticatedUser nId = Named.DocumentsFromWriteNodesAPI $ +api authenticatedUser nId = Named.DocumentsFromWriteNodesAPI $ AsyncJobs $ serveJobsAPI DocumentFromWriteNodeJob $ \jHandle p -> documentsFromWriteNodes authenticatedUser nId p jHandle diff --git a/src/Gargantext/API/Node/File.hs b/src/Gargantext/API/Node/File.hs index 7d5c0ce2..7aed09f7 100644 --- a/src/Gargantext/API/Node/File.hs +++ b/src/Gargantext/API/Node/File.hs @@ -17,19 +17,17 @@ Portability : POSIX module Gargantext.API.Node.File where -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BSL import Data.MIME.Types qualified as DMT -import Data.Swagger (ToSchema(..)) import Data.Text qualified as T import Gargantext.API.Admin.Auth.Types ( AuthenticatedUser, auth_user_id ) import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) -import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Errors.Types ( BackendInternalError ) +import Gargantext.API.Node.File.Types import Gargantext.API.Node.Types ( NewWithFile(NewWithFile) ) -import Gargantext.API.Prelude ( GargM, GargServer ) -import Gargantext.Core.Types (TODO) +import Gargantext.API.Prelude ( GargM ) +import Gargantext.API.Routes.Named.File qualified as Named import Gargantext.Database.Action.Flow.Types ( FlowCmdM ) import Gargantext.Database.Action.Node (mkNodeWithParent) import Gargantext.Database.Admin.Types.Hyperdata.File ( HyperdataFile(..) ) @@ -40,40 +38,14 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Schema.Node (node_hyperdata) import Gargantext.Prelude import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..)) -import Network.HTTP.Media qualified as M import Servant +import Servant.Server.Generic (AsServerT) -data RESPONSE deriving Typeable - -instance Accept RESPONSE where - contentType _ = "text" M.// "*" - -instance MimeRender RESPONSE BSResponse where - mimeRender _ (BSResponse val) = BSL.fromStrict $ val - -type FileApi = Summary "File download" - :> "download" - :> Get '[RESPONSE] (Headers '[Servant.Header "Content-Type" Text] BSResponse) - -instance MimeUnrender RESPONSE BSResponse where - mimeUnrender _ lbs = Right $ BSResponse (BSL.toStrict lbs) - -fileApi :: NodeId -> GargServer FileApi +fileApi :: (HasSettings env, FlowCmdM env err m) + => NodeId + -> m (Headers '[Servant.Header "Content-Type" Text] BSResponse) fileApi nId = fileDownload nId -newtype Contents = Contents BS.ByteString - -instance GargDB.ReadFile Contents where - readFile' fp = do - c <- BS.readFile fp - pure $ Contents c - -newtype BSResponse = BSResponse BS.ByteString - deriving (Generic) - -instance ToSchema BSResponse where - declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO) - fileDownload :: (HasSettings env, FlowCmdM env err m) => NodeId -> m (Headers '[Servant.Header "Content-Type" Text] BSResponse) @@ -102,17 +74,11 @@ fileDownload nId = do -- let settings = embeddedSettings [("", "hello")] -- Tagged $ staticApp settings - -type FileAsyncApi = Summary "File Async Api" - :> "file" - :> "add" - :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog - fileAsyncApi :: AuthenticatedUser -- ^ The logged-in user -> NodeId - -> ServerT FileAsyncApi (GargM Env BackendInternalError) -fileAsyncApi authenticatedUser nId = + -> Named.FileAsyncAPI (AsServerT (GargM Env BackendInternalError)) +fileAsyncApi authenticatedUser nId = Named.FileAsyncAPI $ AsyncJobs $ serveJobsAPI AddFileJob $ \jHandle i -> addWithFile authenticatedUser nId i jHandle diff --git a/src/Gargantext/API/Node/File/Types.hs b/src/Gargantext/API/Node/File/Types.hs new file mode 100644 index 00000000..56561503 --- /dev/null +++ b/src/Gargantext/API/Node/File/Types.hs @@ -0,0 +1,36 @@ + +module Gargantext.API.Node.File.Types where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Swagger (ToSchema(..)) +import Gargantext.Core.Types (TODO) +import Gargantext.Database.GargDB qualified as GargDB +import Gargantext.Prelude +import Network.HTTP.Media qualified as M +import Servant + +data RESPONSE deriving Typeable + +instance Accept RESPONSE where + contentType _ = "text" M.// "*" + +instance MimeRender RESPONSE BSResponse where + mimeRender _ (BSResponse val) = BSL.fromStrict $ val + +instance MimeUnrender RESPONSE BSResponse where + mimeUnrender _ lbs = Right $ BSResponse (BSL.toStrict lbs) + +newtype Contents = Contents BS.ByteString + +instance GargDB.ReadFile Contents where + readFile' fp = do + c <- BS.readFile fp + pure $ Contents c + +newtype BSResponse = BSResponse BS.ByteString + deriving (Generic) + +instance ToSchema BSResponse where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO) + diff --git a/src/Gargantext/API/Node/FrameCalcUpload.hs b/src/Gargantext/API/Node/FrameCalcUpload.hs index 42dbb581..d2eb6fc5 100644 --- a/src/Gargantext/API/Node/FrameCalcUpload.hs +++ b/src/Gargantext/API/Node/FrameCalcUpload.hs @@ -20,6 +20,7 @@ import Data.ByteString.UTF8 qualified as BSU8 import Data.Text qualified as T import Gargantext.API.Admin.Auth.Types ( auth_node_id, AuthenticatedUser ) import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Node.Corpus.New (addToCorpusWithForm) import Gargantext.API.Node.Corpus.New.Types (FileFormat(..), FileType(..)) @@ -43,7 +44,7 @@ import Servant.Server.Generic (AsServerT) api :: AuthenticatedUser -> NodeId -> Named.FrameCalcAPI (AsServerT (GargM Env BackendInternalError)) -api authenticatedUser nId = Named.FrameCalcAPI $ +api authenticatedUser nId = Named.FrameCalcAPI $ AsyncJobs $ serveJobsAPI UploadFrameCalcJob $ \jHandle p -> frameCalcUploadAsync authenticatedUser nId p jHandle diff --git a/src/Gargantext/API/Node/New.hs b/src/Gargantext/API/Node/New.hs index 67b95a8a..e4a1397b 100644 --- a/src/Gargantext/API/Node/New.hs +++ b/src/Gargantext/API/Node/New.hs @@ -23,7 +23,7 @@ module Gargantext.API.Node.New import Control.Lens hiding (elements, Empty) import Gargantext.API.Admin.Auth.Types import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) -import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs (..)) import Gargantext.API.Errors.Types import Gargantext.API.Node.New.Types import Gargantext.API.Prelude @@ -35,7 +35,6 @@ import Gargantext.Database.Prelude (Cmd) import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..)) import Gargantext.Prelude import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..)) -import Servant import Servant.Server.Generic (AsServerT) ------------------------------------------------------------------------ @@ -49,19 +48,13 @@ postNode authenticatedUser pId (PostNode nodeName nt) = do let userId = authenticatedUser ^. auth_user_id mkNodeWithParent nt (Just pId) userId nodeName ------------------------------------------------------------------------- -type PostNodeAsync = Summary "Post Node" - :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] PostNode JobLog - - postNodeAsyncAPI :: AuthenticatedUser -- ^ The logged-in user -> NodeId -- ^ The target node -> Named.PostNodeAsyncAPI (AsServerT (GargM Env BackendInternalError)) -postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ +postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $ serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle ------------------------------------------------------------------------ diff --git a/src/Gargantext/API/Node/Update.hs b/src/Gargantext/API/Node/Update.hs index b5a326c0..38d43454 100644 --- a/src/Gargantext/API/Node/Update.hs +++ b/src/Gargantext/API/Node/Update.hs @@ -18,6 +18,7 @@ module Gargantext.API.Node.Update import Control.Lens (view) import Data.Set qualified as Set import Gargantext.API.Admin.EnvTypes (GargJob(..), Env) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Metrics qualified as Metrics @@ -47,7 +48,7 @@ import Servant.Server.Generic (AsServerT) ------------------------------------------------------------------------ api :: NodeId -> Named.UpdateAPI (AsServerT (GargM Env BackendInternalError)) -api nId = Named.UpdateAPI $ +api nId = Named.UpdateAPI $ AsyncJobs $ serveJobsAPI UpdateNodeJob $ \jHandle p -> updateNode nId p jHandle diff --git a/src/Gargantext/API/Routes.hs b/src/Gargantext/API/Routes.hs index 965fdbf7..54276886 100644 --- a/src/Gargantext/API/Routes.hs +++ b/src/Gargantext/API/Routes.hs @@ -24,6 +24,7 @@ module Gargantext.API.Routes import Control.Lens (view) import Data.Validity import Gargantext.API.Admin.EnvTypes (Env, GargJob(..)) +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Errors.Types import Gargantext.API.Node.Corpus.Annuaire qualified as Annuaire import Gargantext.API.Node.Corpus.New qualified as New @@ -52,7 +53,7 @@ waitAPI n = do ---------------------------------------- addCorpusWithQuery :: User -> Named.AddWithQuery (AsServerT (GargM Env BackendInternalError)) -addCorpusWithQuery user = Named.AddWithQuery $ \cid -> +addCorpusWithQuery user = Named.AddWithQuery $ \cid -> AsyncJobs $ serveJobsAPI AddCorpusQueryJob $ \jHandle q -> do limit <- view $ hasConfig . gc_max_docs_scrapers New.addToCorpusWithQuery user cid q (Just $ fromIntegral limit) jHandle @@ -62,19 +63,19 @@ addCorpusWithQuery user = Named.AddWithQuery $ \cid -> -} addCorpusWithForm :: User -> Named.AddWithForm (AsServerT (GargM Env BackendInternalError)) -addCorpusWithForm user = Named.AddWithForm $ \cid -> +addCorpusWithForm user = Named.AddWithForm $ \cid -> AsyncJobs $ serveJobsAPI AddCorpusFormJob $ \jHandle i -> do -- /NOTE(adinapoli)/ Track the initial steps outside 'addToCorpusWithForm', because it's -- called in a few places, and the job status might be different between invocations. markStarted 3 jHandle New.addToCorpusWithForm user cid i jHandle -addCorpusWithFile :: User -> ServerT New.AddWithFile (GargM Env BackendInternalError) -addCorpusWithFile user cid = - serveJobsAPI AddCorpusFileJob $ \jHandle i -> - New.addToCorpusWithFile user cid i jHandle +--addCorpusWithFile :: User -> ServerT Named.AddWithFile (GargM Env BackendInternalError) +--addCorpusWithFile user cid = +-- serveJobsAPI AddCorpusFileJob $ \jHandle i -> +-- New.addToCorpusWithFile user cid i jHandle addAnnuaireWithForm :: Named.AddAnnuaireWithForm (AsServerT (GargM Env BackendInternalError)) -addAnnuaireWithForm = Named.AddAnnuaireWithForm $ \cid -> +addAnnuaireWithForm = Named.AddAnnuaireWithForm $ \cid -> AsyncJobs $ serveJobsAPI AddAnnuaireFormJob $ \jHandle i -> Annuaire.addToAnnuaireWithForm cid i jHandle diff --git a/src/Gargantext/API/Routes/Named.hs b/src/Gargantext/API/Routes/Named.hs index 0c7d1a82..8ed9796b 100644 --- a/src/Gargantext/API/Routes/Named.hs +++ b/src/Gargantext/API/Routes/Named.hs @@ -53,7 +53,7 @@ newtype SwaggerAPI mode = SwaggerAPI newtype BackEndAPI mode = BackEndAPI { - mkBackendAPI :: mode :- NamedRoutes (MkBackEndAPI (GargAPIVersion GargAPI')) + backendAPI' :: mode :- NamedRoutes (MkBackEndAPI (GargAPIVersion GargAPI')) } deriving Generic @@ -96,7 +96,7 @@ data ForgotPasswordAPI mode = ForgotPasswordAPI data ForgotPasswordAsyncAPI mode = ForgotPasswordAsyncAPI { forgotPasswordAsyncEp :: mode :- Summary "Forgot password asnc" - :> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Annuaire.hs b/src/Gargantext/API/Routes/Named/Annuaire.hs index fa680a0f..11c53fae 100644 --- a/src/Gargantext/API/Routes/Named/Annuaire.hs +++ b/src/Gargantext/API/Routes/Named/Annuaire.hs @@ -18,5 +18,5 @@ newtype AddAnnuaireWithForm mode = AddAnnuaireWithForm :> "add" :> "form" :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] AnnuaireWithForm JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] AnnuaireWithForm JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Contact.hs b/src/Gargantext/API/Routes/Named/Contact.hs index 8bc120f5..f96829df 100644 --- a/src/Gargantext/API/Routes/Named/Contact.hs +++ b/src/Gargantext/API/Routes/Named/Contact.hs @@ -26,5 +26,5 @@ data ContactAPI mode = ContactAPI newtype ContactAsyncAPI mode = ContactAsyncAPI - { addContactAsyncEp :: mode :- AsyncJobs JobLog '[JSON] AddContactParams JobLog + { addContactAsyncEp :: mode :- NamedRoutes (AsyncJobs JobLog '[JSON] AddContactParams JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Corpus.hs b/src/Gargantext/API/Routes/Named/Corpus.hs index 8c34e8f4..9c89d486 100644 --- a/src/Gargantext/API/Routes/Named/Corpus.hs +++ b/src/Gargantext/API/Routes/Named/Corpus.hs @@ -32,7 +32,7 @@ newtype AddWithForm mode = AddWithForm :> "add" :> "form" :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] NewWithForm JobLog) } deriving Generic newtype AddWithQuery mode = AddWithQuery @@ -40,5 +40,5 @@ newtype AddWithQuery mode = AddWithQuery :> "corpus" :> Capture "corpus_id" CorpusId :> "query" - :> AsyncJobs JobLog '[JSON] WithQuery JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] WithQuery JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Document.hs b/src/Gargantext/API/Routes/Named/Document.hs index 5073c5cc..df39ddc7 100644 --- a/src/Gargantext/API/Routes/Named/Document.hs +++ b/src/Gargantext/API/Routes/Named/Document.hs @@ -37,7 +37,7 @@ data DocumentExportEndpoints mode = DocumentExportEndpoints newtype DocumentsFromWriteNodesAPI mode = DocumentsFromWriteNodesAPI { docFromWriteNodesEp :: mode :- Summary " Documents from Write nodes." - :> AsyncJobs JobLog '[JSON] Params JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] Params JobLog) } deriving Generic @@ -46,5 +46,5 @@ newtype DocumentUploadAPI mode = DocumentUploadAPI :> "document" :> "upload" :> "async" - :> AsyncJobs JobLog '[JSON] DocumentUpload JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] DocumentUpload JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/File.hs b/src/Gargantext/API/Routes/Named/File.hs index 4a71987f..2f371244 100644 --- a/src/Gargantext/API/Routes/Named/File.hs +++ b/src/Gargantext/API/Routes/Named/File.hs @@ -9,9 +9,9 @@ module Gargantext.API.Routes.Named.File ( import Data.Text (Text) import GHC.Generics import Gargantext.API.Admin.Orchestrator.Types -import Gargantext.API.Node.File import Gargantext.API.Node.Types import Servant +import Gargantext.API.Node.File.Types data FileAPI mode = FileAPI { fileDownloadEp :: mode :- Summary "File download" @@ -24,6 +24,6 @@ data FileAsyncAPI mode = FileAsyncAPI { addFileAsyncEp :: mode :- Summary "File Async Api" :> "file" :> "add" - :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/FrameCalc.hs b/src/Gargantext/API/Routes/Named/FrameCalc.hs index d85995f7..21535de5 100644 --- a/src/Gargantext/API/Routes/Named/FrameCalc.hs +++ b/src/Gargantext/API/Routes/Named/FrameCalc.hs @@ -17,6 +17,6 @@ newtype FrameCalcAPI mode = FrameCalcAPI :> "add" :> "framecalc" :> "async" - :> AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] FrameCalcUpload JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/List.hs b/src/Gargantext/API/Routes/Named/List.hs index a7a1973f..8691d1a8 100644 --- a/src/Gargantext/API/Routes/Named/List.hs +++ b/src/Gargantext/API/Routes/Named/List.hs @@ -40,7 +40,7 @@ newtype JSONAPI mode = JSONAPI :> "add" :> "form" :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] WithJsonFile JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] WithJsonFile JobLog) } deriving Generic @@ -52,5 +52,5 @@ newtype CSVAPI mode = CSVAPI :> "add" :> "form" :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] WithTextFile JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] WithTextFile JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Node.hs b/src/Gargantext/API/Routes/Named/Node.hs index 8194bc99..d008649c 100644 --- a/src/Gargantext/API/Routes/Named/Node.hs +++ b/src/Gargantext/API/Routes/Named/Node.hs @@ -133,7 +133,7 @@ newtype NodeNodeAPI a mode = NodeNodeAPI newtype PostNodeAsyncAPI mode = PostNodeAsyncAPI { postNodeAsyncEp :: mode :- Summary "Post Node" :> "async" - :> AsyncJobs JobLog '[FormUrlEncoded] PostNode JobLog + :> NamedRoutes (AsyncJobs JobLog '[FormUrlEncoded] PostNode JobLog) } deriving Generic @@ -146,7 +146,7 @@ newtype CatAPI mode = CatAPI newtype UpdateAPI mode = UpdateAPI { updateNodeEp :: mode :- Summary " Update node according to NodeType params" - :> AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] UpdateNodeParams JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Named/Table.hs b/src/Gargantext/API/Routes/Named/Table.hs index 486e57db..f0943fc4 100644 --- a/src/Gargantext/API/Routes/Named/Table.hs +++ b/src/Gargantext/API/Routes/Named/Table.hs @@ -107,5 +107,5 @@ data TableNgramsAsyncAPI mode = TableNgramsAsyncAPI :> "async" :> "charts" :> "update" - :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog + :> NamedRoutes (AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog) } deriving Generic diff --git a/src/Gargantext/API/Routes/Types.hs b/src/Gargantext/API/Routes/Types.hs index 4ba7d9bb..c466c283 100644 --- a/src/Gargantext/API/Routes/Types.hs +++ b/src/Gargantext/API/Routes/Types.hs @@ -5,12 +5,13 @@ module Gargantext.API.Routes.Types where import Data.List qualified as L import Data.Proxy import Gargantext.API.Errors +import Network.Wai import Prelude +import Servant.Client import Servant.Ekg import Servant.Server -import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.Delayed -import Network.Wai +import Servant.Server.Internal.DelayedIO data WithCustomErrorScheme a @@ -30,3 +31,9 @@ instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx instance HasEndpoint sub => HasEndpoint (WithCustomErrorScheme sub) where getEndpoint _ = getEndpoint (Proxy :: Proxy sub) enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy sub) + +instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where + type Client m (WithCustomErrorScheme sub) = GargErrorScheme -> Client m sub + clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req + + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl diff --git a/src/Gargantext/API/Server/Named/Ngrams.hs b/src/Gargantext/API/Server/Named/Ngrams.hs index 7b3730ec..013cd31c 100644 --- a/src/Gargantext/API/Server/Named/Ngrams.hs +++ b/src/Gargantext/API/Server/Named/Ngrams.hs @@ -11,6 +11,7 @@ import Data.Set qualified as Set import Gargantext.API.Admin.Auth (withNamedAccess) import Gargantext.API.Admin.Auth.Types (AuthenticatedUser, PathId (..)) import Gargantext.API.Admin.EnvTypes +import Gargantext.API.Admin.Orchestrator.Types (AsyncJobs(..)) import Gargantext.API.Admin.Types (HasSettings) import Gargantext.API.Errors.Types (BackendInternalError) import Gargantext.API.Metrics qualified as Metrics @@ -65,7 +66,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId apiNgramsAsync :: NodeId -> Named.TableNgramsAsyncAPI (AsServerT (GargM Env BackendInternalError)) -apiNgramsAsync _dId = Named.TableNgramsAsyncAPI $ +apiNgramsAsync _dId = Named.TableNgramsAsyncAPI $ AsyncJobs $ serveJobsAPI TableNgramsJob $ \jHandle i -> withTracer (printDebug "tableNgramsPostChartsAsync") jHandle $ \jHandle' -> tableNgramsPostChartsAsync i jHandle' diff --git a/src/Gargantext/API/Types.hs b/src/Gargantext/API/Types.hs index a0b8d15d..1e393875 100644 --- a/src/Gargantext/API/Types.hs +++ b/src/Gargantext/API/Types.hs @@ -10,23 +10,27 @@ Portability : POSIX -} {-# OPTIONS_GHC -fprint-potential-instances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Gargantext.API.Types where import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BS8 import Data.Either (Either(..)) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text (Text) -import qualified Data.Text.Encoding as E import Data.Typeable +import Gargantext.API.Ngrams.Types () +import Gargantext.API.Node.Document.Export.Types () +import Gargantext.Core.Viz.Graph.Types (Graph(..)) import Network.HTTP.Media ((//), (/:)) import Prelude (($)) +import Servant.API.ContentTypes ( Accept(..) , MimeRender(..) , MimeUnrender(..) ) +import Servant.HTML.Blaze qualified as Blaze +import Servant.Swagger.UI.Core +import Servant.XML.Conduit qualified as S +import qualified Data.ByteString.Lazy.Char8 as BS8 +import qualified Data.Text.Encoding as E import qualified Prelude -import Servant - ( Accept(..) - , MimeRender(..) - , MimeUnrender(..) ) data HTML deriving (Typeable) instance Accept HTML where @@ -41,3 +45,7 @@ instance MimeUnrender HTML Text where mimeUnrender _ bs = Right $ E.decodeUtf8 $ BS8.toStrict bs instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender HTML a where mimeRender _ = encode +instance MimeUnrender Blaze.HTML (SwaggerUiHtml dir api) where + mimeUnrender _ bs = Right (SwaggerUiHtml $ E.decodeUtf8 $ BS8.toStrict bs) +instance MimeUnrender S.XML Graph where + mimeUnrender _ = eitherDecode diff --git a/stack.yaml b/stack.yaml index 1a2e1032..099c87db 100644 --- a/stack.yaml +++ b/stack.yaml @@ -77,8 +77,8 @@ git: "https://github.com/alpmestan/hmatrix.git" subdirs: - packages/base -- commit: b4182487cfe479777c11ca19f3c0d47840b376f6 - git: "https://github.com/alpmestan/servant-job.git" +- commit: 74a3296dfe1f0c4a3ade91336dcc689330e84156 + git: "https://github.com/adinapoli/servant-job.git" subdirs: - . - commit: bc6ca8058077b0b5702ea4b88bd4189cfcad267a diff --git a/test/Test/API/Authentication.hs b/test/Test/API/Authentication.hs index ee553af4..f1593cf3 100644 --- a/test/Test/API/Authentication.hs +++ b/test/Test/API/Authentication.hs @@ -40,7 +40,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do -- testing scenarios start here describe "GET /api/v1.0/version" $ do - let version_api = gargVersionEp genericClient + let version_api = gargVersionEp . gargAPIVersion . mkBackEndAPI $ genericClient it "requires no auth and returns the current version" $ \((_testEnv, port), _) -> do result <- runClientM version_api (clientEnv port) case result of diff --git a/test/Test/API/Routes.hs b/test/Test/API/Routes.hs index cceee887..639204da 100644 --- a/test/Test/API/Routes.hs +++ b/test/Test/API/Routes.hs @@ -1,23 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Test.API.Routes where import Fmt (Builder, (+|), (|+)) -import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse) +import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, Token) import Gargantext.API.Ngrams.Types ( NgramsTable, NgramsTablePatch, OrderBy, TabType, Versioned, VersionedWithCount ) import Gargantext.API.Routes.Named +import Gargantext.API.Routes.Named.Table +import Gargantext.Core.Types (ListId, NodeId) import Gargantext.Core.Types.Main (ListType) import Gargantext.Core.Types.Query (Limit, MaxSize, MinSize, Offset) import Gargantext.Prelude import Network.Wai.Handler.Warp (Port) import Servant.Client (ClientM) import Servant.Client.Generic ( genericClient, AsClientT ) -import Gargantext.API.Routes.Named.Table -import Gargantext.Core.Types (ListId) - +import Gargantext.API.Types () -- MimeUnrender instances +import Gargantext.API.Errors +import Gargantext.API.Routes.Named.Private hiding (tableNgramsAPI) +import Gargantext.API.Routes.Named.Node +import qualified Servant.Auth.Client as S +import qualified Data.Text.Encoding as TE -- This is for requests made by http.client directly to hand-crafted URLs curApi :: Builder @@ -28,15 +34,26 @@ mkUrl _port urlPiece = "/api/" +| curApi |+ urlPiece +-- | The client for the full API. It also serves as a \"proof\" that our +-- whole API has all the required instances to be used in a client. +clientRoutes :: API (AsClientT ClientM) +clientRoutes = genericClient + -- This is for Servant.Client requests auth_api :: AuthRequest -> ClientM AuthResponse -auth_api = authEp cliRoutes - where - cliRoutes :: AuthAPI (AsClientT ClientM) - cliRoutes = genericClient @AuthAPI +auth_api = clientRoutes & apiWithCustomErrorScheme + & ($ GES_new) + & backendAPI + & backendAPI' + & mkBackEndAPI + & gargAPIVersion + & gargAuthAPI + & authEp -table_ngrams_get_api :: TabType +table_ngrams_get_api :: Token + -> NodeId + -> TabType -> ListId -> Limit -> Maybe Offset @@ -46,16 +63,45 @@ table_ngrams_get_api :: TabType -> Maybe OrderBy -> Maybe Text -> ClientM (VersionedWithCount NgramsTable) -table_ngrams_get_api = getNgramsTableEp cliRoutes - where - cliRoutes :: TableNgramsApiGet (AsClientT ClientM) - cliRoutes = genericClient @(TableNgramsApiGet) +table_ngrams_get_api (toServantToken -> token) nodeId = + clientRoutes & apiWithCustomErrorScheme + & ($ GES_new) + & backendAPI + & backendAPI' + & mkBackEndAPI + & gargAPIVersion + & gargPrivateAPI + & mkPrivateAPI + & ($ token) + & nodeEp + & nodeEndpointAPI + & ($ nodeId) + & tableNgramsAPI + & tableNgramsGetAPI + & getNgramsTableEp + +toServantToken :: Token -> S.Token +toServantToken = S.Token . TE.encodeUtf8 -table_ngrams_put_api :: TabType +table_ngrams_put_api :: Token + -> NodeId + -> TabType -> ListId -> Versioned NgramsTablePatch -> ClientM (Versioned NgramsTablePatch) -table_ngrams_put_api = putNgramsTableEp cliRoutes - where - cliRoutes :: TableNgramsApiPut (AsClientT ClientM) - cliRoutes = genericClient @TableNgramsApiPut +table_ngrams_put_api (toServantToken -> token) nodeId = + clientRoutes & apiWithCustomErrorScheme + & ($ GES_new) + & backendAPI + & backendAPI' + & mkBackEndAPI + & gargAPIVersion + & gargPrivateAPI + & mkPrivateAPI + & ($ token) + & nodeEp + & nodeEndpointAPI + & ($ nodeId) + & tableNgramsAPI + & tableNgramsPutAPI + & putNgramsTableEp diff --git a/test/Test/API/Setup.hs b/test/Test/API/Setup.hs index 8ddff0bd..5da9a1f4 100644 --- a/test/Test/API/Setup.hs +++ b/test/Test/API/Setup.hs @@ -17,7 +17,7 @@ import Gargantext.Core.NodeStory import Gargantext.Core.Types.Individu import Gargantext.Database.Action.Flow import Gargantext.Database.Action.User.New -import Gargantext.Database.Admin.Config (userMaster, corpusMasterName) +import Gargantext.Database.Admin.Config (userMaster) import Gargantext.Database.Admin.Trigger.Init import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Prelude diff --git a/test/Test/API/UpdateList.hs b/test/Test/API/UpdateList.hs index 874c37a5..d84af1ea 100644 --- a/test/Test/API/UpdateList.hs +++ b/test/Test/API/UpdateList.hs @@ -134,9 +134,9 @@ tests = sequential $ aroundAll withTestDBAndPort $ do clientEnv <- liftIO $ authenticatedServantClient port token listId <- uploadJSONList port token cId - + let checkNgrams expected = do - eng <- liftIO $ runClientM (table_ngrams_get_api APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv + eng <- liftIO $ runClientM (table_ngrams_get_api token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv case eng of Left err -> fail (show err) Right r -> @@ -144,7 +144,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do , mSetToList $ nt ^. ne_children )) (r ^. vc_data . _NgramsTable) in liftIO $ Set.fromList real `shouldBe` Set.fromList expected - + -- The #313 error is about importedTerm being duplicated -- in a specific case @@ -155,7 +155,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do , NgramsReplace { _patch_old = Nothing , _patch_new = Just nre } ) ] - _ <- liftIO $ runClientM (table_ngrams_put_api APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv + _ <- liftIO $ runClientM (table_ngrams_put_api token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv -- check that new term is added (with no parent) checkNgrams [ (newTerm, []) @@ -166,7 +166,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do ( newTerm , toNgramsPatch [importedTerm] ) ] - _ <- liftIO $ runClientM (table_ngrams_put_api APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv + _ <- liftIO $ runClientM (table_ngrams_put_api token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv -- check that new term is parent of old one checkNgrams [ (newTerm, [importedTerm]) ] diff --git a/test/Test/Utils.hs b/test/Test/Utils.hs index d9cdc2ac..7e41f7cb 100644 --- a/test/Test/Utils.hs +++ b/test/Test/Utils.hs @@ -114,7 +114,7 @@ containsJSON expected = MatchBody matcher authenticatedServantClient :: Int -> T.Text -> IO ClientEnv authenticatedServantClient port token = do - baseUrl <- parseBaseUrl "http://localhost" + baseUrl <- parseBaseUrl "http://0.0.0.0" manager <- newManager defaultManagerSettings let requestAddToken url req = defaultMakeClientRequest url $ addHeader hAuthorization ("Bearer " <> token) -- 2.21.0