Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Grégoire Locqueville
haskell-gargantext
Commits
4a46abad
Commit
4a46abad
authored
Nov 14, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/adinapoli/issue-267-part-2' into dev-new
parents
5bdb077b
6a60ac39
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
78 additions
and
16 deletions
+78
-16
gargantext.cabal
gargantext.cabal
+1
-0
Errors.hs
src/Gargantext/API/Errors.hs
+10
-0
Types.hs
src/Gargantext/API/Errors/Types.hs
+2
-2
Routes.hs
src/Gargantext/API/Routes.hs
+31
-5
Server.hs
src/Gargantext/API/Server.hs
+6
-5
Errors.hs
test/Test/API/Errors.hs
+12
-1
Private.hs
test/Test/API/Private.hs
+16
-3
No files found.
gargantext.cabal
View file @
4a46abad
...
@@ -1049,6 +1049,7 @@ test-suite garg-test-hspec
...
@@ -1049,6 +1049,7 @@ test-suite garg-test-hspec
, base ^>= 4.14.3.0
, base ^>= 4.14.3.0
, boolexpr ^>= 0.2
, boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0
, bytestring ^>= 0.10.12.0
, case-insensitive
, conduit ^>= 1.3.4.2
, conduit ^>= 1.3.4.2
, containers ^>= 0.6.5.1
, containers ^>= 0.6.5.1
, crawlerArxiv
, crawlerArxiv
...
...
src/Gargantext/API/Errors.hs
View file @
4a46abad
...
@@ -6,6 +6,9 @@ module Gargantext.API.Errors (
...
@@ -6,6 +6,9 @@ module Gargantext.API.Errors (
module
Types
module
Types
,
module
Class
,
module
Class
-- * Types
,
GargErrorScheme
(
..
)
-- * Conversion functions
-- * Conversion functions
,
backendErrorToFrontendError
,
backendErrorToFrontendError
,
frontendErrorToServerError
,
frontendErrorToServerError
...
@@ -34,6 +37,13 @@ import qualified Data.Text.Lazy as TL
...
@@ -34,6 +37,13 @@ import qualified Data.Text.Lazy as TL
$
(
deriveHttpStatusCode
''
B
ackendErrorCode
)
$
(
deriveHttpStatusCode
''
B
ackendErrorCode
)
data
GargErrorScheme
=
-- | The old error scheme.
GES_old
-- | The new error scheme, that returns a 'FrontendError'.
|
GES_new
deriving
(
Show
,
Eq
)
-- | Transforms a backend internal error into something that the frontend
-- | Transforms a backend internal error into something that the frontend
-- can consume. This is the only representation we offer to the outside world,
-- can consume. This is the only representation we offer to the outside world,
-- as we later encode this into a 'ServerError' in the main server handler.
-- as we later encode this into a 'ServerError' in the main server handler.
...
...
src/Gargantext/API/Errors/Types.hs
View file @
4a46abad
...
@@ -640,10 +640,10 @@ genFrontendErr be = do
...
@@ -640,10 +640,10 @@ genFrontendErr be = do
pure
$
mkFrontendErr'
txt
$
FE_job_generic_exception
err
pure
$
mkFrontendErr'
txt
$
FE_job_generic_exception
err
instance
ToJSON
BackendErrorCode
where
instance
ToJSON
BackendErrorCode
where
toJSON
=
JSON
.
String
.
T
.
pack
.
drop
3
.
show
toJSON
=
JSON
.
String
.
T
.
pack
.
show
instance
FromJSON
BackendErrorCode
where
instance
FromJSON
BackendErrorCode
where
parseJSON
(
String
s
)
=
case
readMaybe
(
T
.
unpack
$
"EC_"
<>
s
)
of
parseJSON
(
String
s
)
=
case
readMaybe
(
T
.
unpack
s
)
of
Just
v
->
pure
v
Just
v
->
pure
v
Nothing
->
fail
$
"FromJSON BackendErrorCode unexpected value: "
<>
T
.
unpack
s
Nothing
->
fail
$
"FromJSON BackendErrorCode unexpected value: "
<>
T
.
unpack
s
parseJSON
ty
=
typeMismatch
"BackendErrorCode"
ty
parseJSON
ty
=
typeMismatch
"BackendErrorCode"
ty
...
...
src/Gargantext/API/Routes.hs
View file @
4a46abad
...
@@ -15,6 +15,7 @@ Portability : POSIX
...
@@ -15,6 +15,7 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module
Gargantext.API.Routes
module
Gargantext.API.Routes
where
where
...
@@ -28,6 +29,7 @@ import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
...
@@ -28,6 +29,7 @@ import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Auth.PolicyCheck
import
Gargantext.API.Context
import
Gargantext.API.Context
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
Gargantext.API.Errors
(
GargErrorScheme
(
..
))
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.GraphQL
qualified
as
GraphQL
import
Gargantext.API.GraphQL
qualified
as
GraphQL
import
Gargantext.API.Members
(
MembersAPI
,
members
)
import
Gargantext.API.Members
(
MembersAPI
,
members
)
...
@@ -51,11 +53,38 @@ import Gargantext.Database.Prelude (HasConfig(..))
...
@@ -51,11 +53,38 @@ import Gargantext.Database.Prelude (HasConfig(..))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_max_docs_scrapers
)
import
Gargantext.Prelude.Config
(
gc_max_docs_scrapers
)
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Gargantext.Utils.Jobs
(
serveJobsAPI
,
MonadJobStatus
(
..
))
import
Network.Wai
(
requestHeaders
)
import
Servant
import
Servant
import
Servant.Auth
as
SA
import
Servant.Auth
as
SA
import
Servant.Auth.Swagger
()
import
Servant.Auth.Swagger
()
import
Servant.Ekg
import
Servant.Server.Internal.Delayed
import
Servant.Server.Internal.DelayedIO
import
Servant.Swagger
import
Servant.Swagger.UI
import
Servant.Swagger.UI
import
qualified
Data.List
as
L
data
WithCustomErrorScheme
a
instance
(
HasServer
subApi
ctx
)
=>
HasServer
(
WithCustomErrorScheme
subApi
)
ctx
where
type
ServerT
(
WithCustomErrorScheme
subApi
)
m
=
GargErrorScheme
->
ServerT
subApi
m
hoistServerWithContext
_
pc
nt
s
=
hoistServerWithContext
(
Proxy
::
Proxy
subApi
)
pc
nt
.
s
route
Proxy
ctx
d
=
route
(
Proxy
::
Proxy
subApi
)
ctx
(
d
`
addHeaderCheck
`
getErrorScheme
)
where
getErrorScheme
::
DelayedIO
GargErrorScheme
getErrorScheme
=
withRequest
$
\
rq
->
do
let
hdrs
=
requestHeaders
rq
in
case
L
.
lookup
"X-Garg-Error-Scheme"
hdrs
of
Nothing
->
pure
GES_old
Just
"new"
->
pure
GES_new
Just
_
->
pure
GES_old
instance
HasSwagger
(
WithCustomErrorScheme
GargAPI
)
where
toSwagger
_
=
toSwagger
(
Proxy
::
Proxy
GargAPI
)
instance
HasEndpoint
sub
=>
HasEndpoint
(
WithCustomErrorScheme
sub
)
where
getEndpoint
_
=
getEndpoint
(
Proxy
::
Proxy
sub
)
enumerateEndpoints
_
=
enumerateEndpoints
(
Proxy
::
Proxy
sub
)
type
GargAPI
=
MkGargAPI
(
GargAPIVersion
GargAPI'
)
type
GargAPI
=
MkGargAPI
(
GargAPIVersion
GargAPI'
)
...
@@ -207,10 +236,7 @@ type GargPrivateAPI' =
...
@@ -207,10 +236,7 @@ type GargPrivateAPI' =
-- :<|> "auth" :> Capture "node_id" Int :> NodeAPI
-- :<|> "auth" :> Capture "node_id" Int :> NodeAPI
---------------------------------------------------------------------
---------------------------------------------------------------------
type
API
=
SwaggerAPI
type
API
=
WithCustomErrorScheme
(
SwaggerAPI
:<|>
GargAPI
:<|>
GraphQL
.
API
:<|>
FrontEndAPI
)
:<|>
GargAPI
:<|>
GraphQL
.
API
:<|>
FrontEndAPI
-- | API for serving @swagger.json@
-- | API for serving @swagger.json@
type
SwaggerAPI
=
SwaggerSchemaUI
"swagger-ui"
"swagger.json"
type
SwaggerAPI
=
SwaggerSchemaUI
"swagger-ui"
"swagger.json"
...
...
src/Gargantext/API/Server.hs
View file @
4a46abad
...
@@ -53,18 +53,19 @@ serverGargAPI baseUrl -- orchestrator
...
@@ -53,18 +53,19 @@ serverGargAPI baseUrl -- orchestrator
server
::
Env
->
IO
(
Server
API
)
server
::
Env
->
IO
(
Server
API
)
server
env
=
do
server
env
=
do
-- orchestrator <- scrapyOrchestrator env
-- orchestrator <- scrapyOrchestrator env
pure
$
swaggerSchemaUIServer
swaggerDoc
pure
$
\
errScheme
->
swaggerSchemaUIServer
swaggerDoc
:<|>
hoistServerWithContext
:<|>
hoistServerWithContext
(
Proxy
::
Proxy
GargAPI
)
(
Proxy
::
Proxy
GargAPI
)
(
Proxy
::
Proxy
AuthContext
)
(
Proxy
::
Proxy
AuthContext
)
transformJSON
(
transformJSON
errScheme
)
(
serverGargAPI
(
env
^.
hasConfig
.
gc_url_backend_api
))
(
serverGargAPI
(
env
^.
hasConfig
.
gc_url_backend_api
))
:<|>
hoistServerWithContext
:<|>
hoistServerWithContext
(
Proxy
::
Proxy
GraphQL
.
API
)
(
Proxy
::
Proxy
GraphQL
.
API
)
(
Proxy
::
Proxy
AuthContext
)
(
Proxy
::
Proxy
AuthContext
)
transformJSON
(
transformJSON
errScheme
)
GraphQL
.
api
GraphQL
.
api
:<|>
frontEndServer
:<|>
frontEndServer
where
where
transformJSON
::
forall
a
.
GargM
Env
BackendInternalError
a
->
Handler
a
transformJSON
::
forall
a
.
GargErrorScheme
->
GargM
Env
BackendInternalError
a
->
Handler
a
transformJSON
=
Handler
.
withExceptT
showAsServantJSONErr
.
(`
runReaderT
`
env
)
transformJSON
GES_old
=
Handler
.
withExceptT
showAsServantJSONErr
.
(`
runReaderT
`
env
)
transformJSON
GES_new
=
Handler
.
withExceptT
(
frontendErrorToServerError
.
backendErrorToFrontendError
)
.
(`
runReaderT
`
env
)
test/Test/API/Errors.hs
View file @
4a46abad
...
@@ -10,7 +10,7 @@ import Network.Wai.Test
...
@@ -10,7 +10,7 @@ import Network.Wai.Test
import
Servant
import
Servant
import
Servant.Auth.Client
()
import
Servant.Auth.Client
()
import
Servant.Client
import
Servant.Client
import
Test.API.Private
(
protected
,
withValidLogin
)
import
Test.API.Private
(
protected
,
withValidLogin
,
protectedNewError
)
import
Test.API.Setup
(
withTestDBAndPort
,
setupEnvironment
,
mkUrl
,
createAliceAndBob
)
import
Test.API.Setup
(
withTestDBAndPort
,
setupEnvironment
,
mkUrl
,
createAliceAndBob
)
import
Test.Hspec
import
Test.Hspec
import
Test.Hspec.Wai.Internal
(
withApplication
)
import
Test.Hspec.Wai.Internal
(
withApplication
)
...
@@ -48,3 +48,14 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
...
@@ -48,3 +48,14 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
->
liftIO
$
do
->
liftIO
$
do
statusCode
`
shouldBe
`
404
statusCode
`
shouldBe
`
404
simpleBody
`
shouldBe
`
[
r
|
{"error":"Node does not exist (nodeId-99)"}
|]
simpleBody
`
shouldBe
`
[
r
|
{"error":"Node does not exist (nodeId-99)"}
|]
it
"returns the new error if header X-Garg-Error-Scheme: new is passed"
$
\
((
_testEnv
,
port
),
app
)
->
do
withApplication
app
$
do
withValidLogin
port
"gargantua"
(
GargPassword
"secret_key"
)
$
\
token
->
do
res
<-
protectedNewError
token
"GET"
(
mkUrl
port
"/node/99"
)
""
case
res
of
SResponse
{
..
}
|
Status
{
..
}
<-
simpleStatus
->
liftIO
$
do
statusCode
`
shouldBe
`
404
simpleBody
`
shouldBe
`
[
r
|
{"data":{"node_id":99},"diagnostic":"FE_node_lookup_failed_not_found {nenf_node_id = nodeId-99}","type":"EC_404__node_lookup_failed_not_found"}
|]
test/Test/API/Private.hs
View file @
4a46abad
...
@@ -10,9 +10,12 @@ module Test.API.Private (
...
@@ -10,9 +10,12 @@ module Test.API.Private (
,
withValidLogin
,
withValidLogin
,
getJSON
,
getJSON
,
protected
,
protected
,
protectedWith
,
protectedNewError
)
where
)
where
import
Data.ByteString.Lazy
qualified
as
L
import
Data.ByteString.Lazy
qualified
as
L
import
Data.CaseInsensitive
qualified
as
CI
import
Data.Text.Encoding
qualified
as
TE
import
Data.Text.Encoding
qualified
as
TE
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Routes
import
Gargantext.API.Routes
...
@@ -36,11 +39,21 @@ import Test.Utils (jsonFragment, shouldRespondWith')
...
@@ -36,11 +39,21 @@ import Test.Utils (jsonFragment, shouldRespondWith')
-- | Issue a request with a valid 'Authorization: Bearer' inside.
-- | Issue a request with a valid 'Authorization: Bearer' inside.
protected
::
Token
->
Method
->
ByteString
->
L
.
ByteString
->
WaiSession
()
SResponse
protected
::
Token
->
Method
->
ByteString
->
L
.
ByteString
->
WaiSession
()
SResponse
protected
tkn
mth
url
payload
=
protected
tkn
mth
url
=
protectedWith
mempty
tkn
mth
url
request
mth
url
[
(
hAccept
,
"application/json;charset=utf-8"
)
protectedWith
::
[
Network
.
HTTP
.
Types
.
Header
]
->
Token
->
Method
->
ByteString
->
L
.
ByteString
->
WaiSession
()
SResponse
protectedWith
extraHeaders
tkn
mth
url
payload
=
request
mth
url
([
(
hAccept
,
"application/json;charset=utf-8"
)
,
(
hContentType
,
"application/json"
)
,
(
hContentType
,
"application/json"
)
,
(
hAuthorization
,
"Bearer "
<>
TE
.
encodeUtf8
tkn
)
,
(
hAuthorization
,
"Bearer "
<>
TE
.
encodeUtf8
tkn
)
]
payload
]
<>
extraHeaders
)
payload
protectedNewError
::
Token
->
Method
->
ByteString
->
L
.
ByteString
->
WaiSession
()
SResponse
protectedNewError
tkn
mth
url
=
protectedWith
newErrorFormat
tkn
mth
url
where
newErrorFormat
=
[(
CI
.
mk
"X-Garg-Error-Scheme"
,
"new"
)]
getJSON
::
ByteString
->
WaiSession
()
SResponse
getJSON
::
ByteString
->
WaiSession
()
SResponse
getJSON
url
=
getJSON
url
=
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment