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
Christian Merten
haskell-gargantext
Commits
09de17bd
Unverified
Commit
09de17bd
authored
Sep 24, 2019
by
Nicolas Pouillard
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Secure API with JWT auth. Part 1
parent
365c0e0d
Changes
23
Hide whitespace changes
Inline
Side-by-side
Showing
23 changed files
with
323 additions
and
111 deletions
+323
-111
Main.hs
bin/gargantext-import/Main.hs
+1
-1
Main.hs
bin/gargantext-init/Main.hs
+1
-1
Dockerfile
devops/docker/Dockerfile
+1
-1
docker-postgres
devops/docker/docker-postgres
+1
-1
package.yaml
package.yaml
+5
-1
API.hs
src/Gargantext/API.hs
+45
-39
Auth.hs
src/Gargantext/API/Auth.hs
+59
-10
New.hs
src/Gargantext/API/Corpus/New.hs
+2
-0
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+49
-0
Tools.hs
src/Gargantext/API/Ngrams/Tools.hs
+4
-0
Node.hs
src/Gargantext/API/Node.hs
+2
-0
Settings.hs
src/Gargantext/API/Settings.hs
+20
-21
Types.hs
src/Gargantext/API/Types.hs
+75
-5
Database.hs
src/Gargantext/Database.hs
+2
-2
Access.hs
src/Gargantext/Database/Access.hs
+1
-0
Bashql.hs
src/Gargantext/Database/Bashql.hs
+5
-2
Facet.hs
src/Gargantext/Database/Facet.hs
+19
-5
Flow.hs
src/Gargantext/Database/Flow.hs
+22
-10
Pairing.hs
src/Gargantext/Database/Flow/Pairing.hs
+1
-0
Update.hs
src/Gargantext/Database/Node/Update.hs
+1
-0
TextSearch.hs
src/Gargantext/Database/TextSearch.hs
+2
-0
Node.hs
src/Gargantext/Database/Types/Node.hs
+4
-11
stack.yaml
stack.yaml
+1
-1
No files found.
bin/gargantext-import/Main.hs
View file @
09de17bd
...
...
@@ -30,7 +30,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
import
Gargantext.Database.Schema.User
(
insertUsersDemo
)
import
Gargantext.Text.Terms
(
TermType
(
..
))
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.API
--
(GargError)
import
Gargantext.API
.Types
(
GargError
)
import
Gargantext.API.Node
()
-- instances
import
Gargantext.API.Settings
(
withDevEnv
,
runCmdDev
,
DevEnv
)
import
System.Environment
(
getArgs
)
...
...
bin/gargantext-init/Main.hs
View file @
09de17bd
...
...
@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
import
Gargantext.Database.Schema.User
(
insertUsersDemo
,
UserId
)
import
Gargantext.Text.Terms
(
TermType
(
..
))
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.API
--
(GargError)
import
Gargantext.API
.Types
(
GargError
)
import
Gargantext.API.Node
()
-- instances
import
Gargantext.API.Settings
(
withDevEnv
,
runCmdDev
,
DevEnv
)
--import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
...
...
devops/docker/Dockerfile
View file @
09de17bd
from
fpco/stack-build:lts-1
2.2
6
from
fpco/stack-build:lts-1
4.
6
RUN
apt-get update
&&
\
apt-get
install
-y
git libigraph0-dev
&&
\
...
...
devops/docker/docker-postgres
View file @
09de17bd
...
...
@@ -4,6 +4,6 @@ docker rm --volumes dbgarg || :
export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
sleep 3
docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 <
src/Gargantext/Database/Schema
/schema.sql
docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 <
devops/postgres
/schema.sql
#docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres -U gargantua -d gargandbV5 < gargantext.dump
#docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres -U gargantua gargandbV5
package.yaml
View file @
09de17bd
...
...
@@ -33,6 +33,7 @@ library:
# - Gargantext.API.Orchestrator
-
Gargantext.API.Search
-
Gargantext.API.Settings
-
Gargantext.API.Types
-
Gargantext.Core
-
Gargantext.Core.Types
-
Gargantext.Core.Types.Main
...
...
@@ -130,7 +131,7 @@ library:
-
hlcm
-
ini
-
insert-ordered-containers
-
jose
-jwt
-
jose
# - kmeans-vector
-
json-stream
-
KMP
...
...
@@ -160,6 +161,7 @@ library:
-
simple-reflect
-
cereal
# (IGraph)
-
singletons
# (IGraph)
-
quickcheck-instances
-
random
-
rake
-
regex-compat
...
...
@@ -169,6 +171,8 @@ library:
-
semigroups
-
servant
-
servant-auth
-
servant-auth-server >= 0.4.4.0
-
servant-auth-swagger
-
servant-blaze
-
servant-client
# - servant-job
...
...
src/Gargantext/API.hs
View file @
09de17bd
...
...
@@ -55,6 +55,9 @@ import Network.Wai
import
Network.Wai.Handler.Warp
hiding
(
defaultSettings
)
import
Servant
import
Servant.Auth
as
SA
import
Servant.Auth.Server
(
AuthResult
(
..
))
import
Servant.Auth.Swagger
()
import
Servant.HTML.Blaze
(
HTML
)
--import Servant.Mock (mock)
--import Servant.Job.Server (WithCallbacks)
...
...
@@ -68,7 +71,7 @@ import Text.Blaze.Html (Html)
--import Gargantext.API.Swagger
--import Gargantext.Database.Node.Contact (HyperdataContact)
import
Gargantext.API.Auth
(
AuthRequest
,
AuthResponse
,
auth
)
import
Gargantext.API.Auth
(
AuthRequest
,
AuthResponse
,
AuthenticatedUser
(
..
),
AuthContext
,
auth
)
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
Gargantext.API.FrontEnd
(
FrontEndAPI
,
frontEndServer
)
import
Gargantext.API.Ngrams
(
HasRepo
(
..
),
HasRepoSaver
(
..
),
saveRepo
,
TableNgramsApi
,
apiNgramsTableDoc
)
...
...
@@ -76,9 +79,6 @@ import Gargantext.API.Node
import
Gargantext.API.Search
(
SearchPairsAPI
,
searchPairs
)
import
Gargantext.API.Types
import
qualified
Gargantext.API.Corpus.New
as
New
import
Gargantext.Core.Types
(
HasInvalidError
(
..
))
import
Gargantext.Database.Schema.Node
(
HasNodeError
(
..
),
NodeError
)
import
Gargantext.Database.Tree
(
HasTreeError
(
..
),
TreeError
)
import
Gargantext.Database.Types.Node
import
Gargantext.Database.Types.Node
(
NodeId
,
CorpusId
,
AnnuaireId
)
import
Gargantext.Database.Utils
(
HasConnection
)
...
...
@@ -109,24 +109,8 @@ import Network.HTTP.Types hiding (Query)
import
Gargantext.API.Settings
data
GargError
=
GargNodeError
NodeError
|
GargTreeError
TreeError
|
GargInvalidError
Validation
deriving
(
Show
)
makePrisms
''
G
argError
instance
HasNodeError
GargError
where
_NodeError
=
_GargNodeError
instance
HasInvalidError
GargError
where
_InvalidError
=
_GargInvalidError
instance
HasTreeError
GargError
where
_TreeError
=
_GargTreeError
showAsServantErr
::
Show
a
=>
a
->
ServerError
showAsServantErr
::
GargError
->
ServerError
showAsServantErr
(
GargServerError
err
)
=
err
showAsServantErr
a
=
err500
{
errBody
=
BL8
.
pack
$
show
a
}
fireWall
::
Applicative
f
=>
Request
->
FireWall
->
f
Bool
...
...
@@ -231,15 +215,21 @@ type GargAPI' =
"auth"
:>
Summary
"AUTH API"
:>
ReqBody
'[
J
SON
]
AuthRequest
:>
Post
'[
J
SON
]
AuthResponse
-- TODO-ACCESS here we want to request a particular header for
-- auth and capabilities.
:<|>
GargPrivateAPI
type
GargPrivateAPI
=
SA
.
Auth
'[
S
A
.
JWT
]
AuthenticatedUser
:>
GargPrivateAPI'
type
GargPrivateAPI'
=
-- Roots endpoint
:<|>
"user"
:>
Summary
"First user endpoint"
"user"
:>
Summary
"First user endpoint"
:>
Roots
-- Node endpoint
:<|>
"node"
:>
Summary
"Node endpoint"
:>
Capture
"id"
NodeId
:>
NodeAPI
HyperdataAny
-- Corpus endpoint
:<|>
"corpus"
:>
Summary
"Corpus endpoint"
:>
Capture
"id"
CorpusId
:>
NodeAPI
HyperdataCorpus
...
...
@@ -290,6 +280,10 @@ type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
type
API
=
SwaggerFrontAPI
:<|>
GargAPI
:<|>
Get
'[
H
TML
]
Html
-- This is the concrete monad. It needs to be used as little as possible,
-- instead, prefer GargServer, GargServerT, GargServerC.
type
GargServerM
env
err
=
ReaderT
env
(
ExceptT
err
IO
)
---------------------------------------------------------------------
-- | Server declarations
...
...
@@ -298,19 +292,28 @@ server :: forall env. (HasConnection env, HasRepo env, HasSettings env)
server
env
=
do
-- orchestrator <- scrapyOrchestrator env
pure
$
swaggerFront
:<|>
hoistServer
(
Proxy
::
Proxy
GargAPI
)
transform
serverGargAPI
:<|>
hoistServer
WithContext
(
Proxy
::
Proxy
GargAPI
)
(
Proxy
::
Proxy
AuthContext
)
transform
serverGargAPI
:<|>
serverStatic
where
transform
::
forall
a
.
ReaderT
env
(
ExceptT
GargError
IO
)
a
->
Handler
a
transform
::
forall
a
.
GargServerM
env
GargError
a
->
Handler
a
transform
=
Handler
.
withExceptT
showAsServantErr
.
(`
runReaderT
`
env
)
serverGargAPI
::
GargServer
GargAPI
serverGargAPI
::
GargServer
T
env
err
(
GargServerM
env
err
)
GargAPI
serverGargAPI
-- orchestrator
=
auth
:<|>
roots
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataAny
)
fakeUserId
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataCorpus
)
fakeUserId
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataAnnuaire
)
fakeUserId
=
auth
:<|>
serverPrivateGargAPI
-- :<|> orchestrator
serverPrivateGargAPI
::
GargServerT
env
err
(
GargServerM
env
err
)
GargPrivateAPI
serverPrivateGargAPI
(
Authenticated
auser
)
=
serverPrivateGargAPI'
auser
serverPrivateGargAPI
_
=
throwAll'
(
_ServerError
#
err401
)
-- Here throwAll' requires a concrete type for the monad.
serverPrivateGargAPI'
::
AuthenticatedUser
->
GargServer
GargPrivateAPI'
serverPrivateGargAPI'
(
AuthenticatedUser
(
NodeId
uid
))
=
roots
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataAny
)
uid
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataCorpus
)
uid
:<|>
nodeAPI
(
Proxy
::
Proxy
HyperdataAnnuaire
)
uid
:<|>
apiNgramsTableDoc
:<|>
nodesAPI
:<|>
count
-- TODO: undefined
...
...
@@ -318,10 +321,7 @@ serverGargAPI -- orchestrator
:<|>
graphAPI
-- TODO: mock
:<|>
treeAPI
:<|>
New
.
api
:<|>
New
.
info
fakeUserId
-- :<|> orchestrator
where
fakeUserId
=
2
-- TODO, byDefault user1 (if users automatically generated with inserUsersDemo)
:<|>
New
.
info
uid
serverStatic
::
Server
(
Get
'[
H
TML
]
Html
)
serverStatic
=
$
(
do
...
...
@@ -341,7 +341,13 @@ swaggerFront = schemaUiServer swaggerDoc
---------------------------------------------------------------------
makeApp
::
(
HasConnection
env
,
HasRepo
env
,
HasSettings
env
)
=>
env
->
IO
Application
makeApp
=
fmap
(
serve
api
)
.
server
makeApp
env
=
serveWithContext
api
cfg
<$>
server
env
where
cfg
::
Servant
.
Context
AuthContext
cfg
=
env
^.
settings
.
jwtSettings
:.
env
^.
settings
.
cookieSettings
-- :. authCheck env
:.
EmptyContext
--appMock :: Application
--appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
...
...
src/Gargantext/API/Auth.hs
View file @
09de17bd
...
...
@@ -16,6 +16,8 @@ Main authorisation of Gargantext are managed in this module
-- 2: Implement the Auth API backend
https://github.com/haskell-servant/servant-auth
TODO-ACCESS Critical
-}
{-# LANGUAGE NoImplicitPrelude #-}
...
...
@@ -28,15 +30,22 @@ Main authorisation of Gargantext are managed in this module
module
Gargantext.API.Auth
where
import
Control.Lens
(
view
)
import
Control.Monad.IO.Class
(
liftIO
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.List
(
elem
)
import
Data.Swagger
import
Data.Text
(
Text
,
reverse
)
import
Data.Text.Lazy
(
toStrict
)
import
Data.Text.Lazy.Encoding
(
decodeUtf8
)
import
GHC.Generics
(
Generic
)
import
Servant.Auth.Server
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
import
Gargantext.API.Settings
import
Gargantext.API.Types
(
HasJoseError
(
..
),
joseError
)
import
Gargantext.Database.Root
(
getRoot
)
import
Gargantext.Database.Types.Node
(
NodePoly
(
_node_id
),
NodeId
)
import
Gargantext.Database.Utils
(
Cmd
)
import
Gargantext.Database.Utils
(
Cmd
'
,
HasConnection
)
import
Gargantext.Prelude
hiding
(
reverse
)
import
Test.QuickCheck
(
elements
,
oneof
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
...
...
@@ -74,15 +83,30 @@ type TreeId = NodeId
data
CheckAuth
=
InvalidUser
|
InvalidPassword
|
Valid
Token
TreeId
deriving
(
Eq
)
checkAuthRequest
::
Username
->
Password
->
Cmd
err
CheckAuth
makeTokenForUser
::
(
HasSettings
env
,
HasJoseError
err
)
=>
NodeId
->
Cmd'
env
err
Token
makeTokenForUser
uid
=
do
jwtS
<-
view
$
settings
.
jwtSettings
e
<-
liftIO
$
makeJWT
(
AuthenticatedUser
uid
)
jwtS
Nothing
-- TODO-SECURITY here we can implement token expiration ^^.
either
joseError
(
pure
.
toStrict
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
checkAuthRequest
::
(
HasSettings
env
,
HasConnection
env
,
HasJoseError
err
)
=>
Username
->
Password
->
Cmd'
env
err
CheckAuth
checkAuthRequest
u
p
|
not
(
u
`
elem
`
arbitraryUsername
)
=
pure
InvalidUser
|
u
/=
reverse
p
=
pure
InvalidPassword
|
otherwise
=
do
muId
<-
getRoot
"user1"
pure
$
maybe
InvalidUser
(
Valid
"token"
.
_node_id
)
$
head
muId
auth
::
AuthRequest
->
Cmd
err
AuthResponse
muId
<-
head
<$>
getRoot
"user1"
-- TODO user1 hard-coded
case
_node_id
<$>
muId
of
Nothing
->
pure
InvalidUser
Just
uid
->
do
token
<-
makeTokenForUser
uid
pure
$
Valid
token
uid
auth
::
(
HasSettings
env
,
HasConnection
env
,
HasJoseError
err
)
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
case
checkAuthRequest'
of
...
...
@@ -90,9 +114,34 @@ auth (AuthRequest u p) = do
InvalidPassword
->
pure
$
AuthResponse
Nothing
(
Just
$
AuthInvalid
"Invalid password"
)
Valid
to
trId
->
pure
$
AuthResponse
(
Just
$
AuthValid
to
trId
)
Nothing
newtype
AuthenticatedUser
=
AuthenticatedUser
{
_au_id
::
NodeId
}
deriving
(
Generic
)
$
(
deriveJSON
(
unPrefix
"_au_"
)
''
A
uthenticatedUser
)
instance
ToSchema
AuthenticatedUser
instance
ToJWT
AuthenticatedUser
instance
FromJWT
AuthenticatedUser
--type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
-- TODO-SECURITY why is the CookieSettings necessary?
type
AuthContext
=
'[
J
WTSettings
,
CookieSettings
]
-- , BasicAuthCfg
{-
instance FromBasicAuthData AuthenticatedUser where
fromBasicAuthData authData authCheckFunction = authCheckFunction authData
authCheck :: forall env. env
-> BasicAuthData
-> IO (AuthResult AuthenticatedUser)
authCheck _env (BasicAuthData login password) = pure $
maybe Indefinite Authenticated $ TODO
-}
-- | Instances
$
(
deriveJSON
(
unPrefix
"_authReq_"
)
''
A
uthRequest
)
instance
ToSchema
AuthRequest
instance
ToSchema
AuthRequest
-- TODO-SWAGGER unPrefix
instance
Arbitrary
AuthRequest
where
arbitrary
=
elements
[
AuthRequest
u
p
...
...
@@ -101,20 +150,20 @@ instance Arbitrary AuthRequest where
]
$
(
deriveJSON
(
unPrefix
"_authRes_"
)
''
A
uthResponse
)
instance
ToSchema
AuthResponse
instance
ToSchema
AuthResponse
-- TODO-SWAGGER unPrefix
instance
Arbitrary
AuthResponse
where
arbitrary
=
oneof
[
AuthResponse
Nothing
.
Just
<$>
arbitrary
,
flip
AuthResponse
Nothing
.
Just
<$>
arbitrary
]
$
(
deriveJSON
(
unPrefix
"_authInv_"
)
''
A
uthInvalid
)
instance
ToSchema
AuthInvalid
instance
ToSchema
AuthInvalid
-- TODO-SWAGGER unPrefix
instance
Arbitrary
AuthInvalid
where
arbitrary
=
elements
[
AuthInvalid
m
|
m
<-
[
"Invalid user"
,
"Invalid password"
]
]
$
(
deriveJSON
(
unPrefix
"_authVal_"
)
''
A
uthValid
)
instance
ToSchema
AuthValid
instance
ToSchema
AuthValid
-- TODO-SWAGGER unPrefix
instance
Arbitrary
AuthValid
where
arbitrary
=
elements
[
AuthValid
to
tr
|
to
<-
[
"token0"
,
"token1"
]
...
...
src/Gargantext/API/Corpus/New.hs
View file @
09de17bd
...
...
@@ -70,6 +70,8 @@ type Api = Summary "New Corpus endpoint"
:<|>
Get
'[
J
SON
]
ApiInfo
-- | TODO manage several apis
-- TODO-ACCESS
-- TODO this is only the POST
api
::
(
FlowCmdM
env
err
m
)
=>
Query
->
m
CorpusId
api
(
Query
q
_
as
)
=
do
cId
<-
case
head
as
of
...
...
src/Gargantext/API/Ngrams.hs
View file @
09de17bd
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
...
...
@@ -32,6 +33,52 @@ add get
{-# OPTIONS -fno-warn-orphans #-}
module
Gargantext.API.Ngrams
(
TableNgramsApi
,
TableNgramsApiGet
,
TableNgramsApiPut
,
TableNgramsApiPost
,
getTableNgrams
,
putListNgrams
,
tableNgramsPost
,
apiNgramsTableCorpus
,
apiNgramsTableDoc
,
NgramsStatePatch
,
NgramsTablePatch
,
NgramsElement
,
mkNgramsElement
,
mergeNgramsElement
,
RootParent
(
..
)
,
MSet
,
mSetFromList
,
mSetToList
,
Repo
(
..
)
,
r_version
,
r_state
,
NgramsRepo
,
NgramsRepoElement
(
..
)
,
saveRepo
,
initRepo
,
RepoEnv
(
..
)
,
renv_var
,
renv_lock
,
TabType
(
..
)
,
ngramsTypeFromTabType
,
HasRepoVar
(
..
)
,
HasRepoSaver
(
..
)
,
HasRepo
(
..
)
,
RepoCmdM
,
QueryParamR
,
TODO
(
..
)
)
where
-- import Debug.Trace (trace)
...
...
@@ -798,12 +845,14 @@ putListNgrams listId ngramsType nes = do
where
m
=
Map
.
fromList
$
(
\
n
->
(
n
^.
ne_ngrams
,
ngramsElementToRepo
n
))
<$>
nes
-- TODO-ACCESS check
tableNgramsPost
::
RepoCmdM
env
err
m
=>
TabType
->
NodeId
->
Maybe
ListType
->
[
NgramsTerm
]
->
m
()
tableNgramsPost
tabType
listId
mayList
=
putListNgrams
listId
(
ngramsTypeFromTabType
tabType
)
.
fmap
(
newNgramsElement
mayList
)
-- Apply the given patch to the DB and returns the patch to be applied on the
-- client.
-- TODO-ACCESS check
tableNgramsPut
::
(
HasInvalidError
err
,
RepoCmdM
env
err
m
)
=>
TabType
->
ListId
->
Versioned
NgramsTablePatch
...
...
src/Gargantext/API/Ngrams/Tools.hs
View file @
09de17bd
...
...
@@ -33,6 +33,10 @@ import qualified Data.Set as Set
type
RootTerm
=
Text
-- TODO-ACCESS: We want to do the security check before entering here.
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams
::
RepoCmdM
env
err
m
=>
[
ListId
]
->
NgramsType
->
m
(
Map
Text
NgramsRepoElement
)
...
...
src/Gargantext/API/Node.hs
View file @
09de17bd
...
...
@@ -7,6 +7,8 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-- TODO-SECURITY: Critical
-- TODO-ACCESS: CanGetNode
-- TODO-EVENTS: No events as this is a read only query.
Node API
...
...
src/Gargantext/API/Settings.hs
View file @
09de17bd
...
...
@@ -6,6 +6,8 @@ License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO-SECURITY: Critical
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
...
...
@@ -40,16 +42,15 @@ import Data.Aeson
import
Data.Maybe
(
fromMaybe
)
import
Data.Either
(
either
)
import
Data.Text
import
Data.Text.Encoding
(
encodeUtf8
)
--
import Data.Text.Encoding (encodeUtf8)
import
Data.ByteString
(
ByteString
)
import
qualified
Data.ByteString.Lazy
as
L
import
Servant
import
Servant.Auth.Server
(
defaultJWTSettings
,
JWTSettings
,
CookieSettings
,
defaultCookieSettings
,
readKey
,
writeKey
)
import
Servant.Client
(
BaseUrl
,
parseBaseUrl
)
--import Servant.Job.Async (newJobEnv, defaultSettings)
import
Web.HttpApiData
(
parseUrlPiece
)
import
qualified
Jose.Jwk
as
Jose
import
qualified
Jose.Jwa
as
Jose
import
Control.Concurrent
import
Control.Debounce
(
mkDebounce
,
defaultDebounceSettings
,
debounceFreq
,
debounceAction
)
...
...
@@ -77,7 +78,8 @@ data Settings = Settings
,
_logLevelLimit
::
LogLevel
-- log level from the monad-logger package
-- , _dbServer :: Text
-- ^ this is not used yet
,
_jwtSecret
::
Jose
.
Jwk
-- key from the jose-jwt package
,
_jwtSettings
::
JWTSettings
,
_cookieSettings
::
CookieSettings
,
_sendLoginEmails
::
SendEmailType
,
_scrapydUrl
::
BaseUrl
,
_fileFolder
::
FilePath
...
...
@@ -89,29 +91,22 @@ class HasSettings env where
settings
::
Getter
env
Settings
parseJwk
::
Text
->
Jose
.
Jwk
parseJwk
secretStr
=
jwk
where
secretBs
=
encodeUtf8
secretStr
jwk
=
Jose
.
SymmetricJwk
secretBs
Nothing
Nothing
(
Just
$
Jose
.
Signed
Jose
.
HS256
)
devSettings
::
Settings
devSettings
=
Settings
devSettings
::
FilePath
->
IO
Settings
devSettings
jwkFile
=
do
jwkExists
<-
doesFileExist
jwkFile
when
(
not
jwkExists
)
$
writeKey
jwkFile
jwk
<-
readKey
jwkFile
pure
$
Settings
{
_allowedOrigin
=
"http://localhost:8008"
,
_allowedHost
=
"localhost:3000"
,
_appPort
=
3000
,
_logLevelLimit
=
LevelDebug
-- , _dbServer = "localhost"
-- generate with dd if=/dev/urandom bs=1 count=32 | base64
-- make sure jwtSecret differs between development and production, because you do not want
-- your production key inside source control.
,
_jwtSecret
=
parseJwk
"MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
,
_sendLoginEmails
=
LogEmailToConsole
,
_scrapydUrl
=
fromMaybe
(
panic
"Invalid scrapy URL"
)
$
parseBaseUrl
"http://localhost:6800"
,
_fileFolder
=
"data"
,
_cookieSettings
=
defaultCookieSettings
-- TODO-SECURITY tune
,
_jwtSettings
=
defaultJWTSettings
jwk
-- TODO-SECURITY tune
}
...
...
@@ -232,10 +227,13 @@ readRepoEnv = do
saver
<-
mkRepoSaver
mvar
pure
$
RepoEnv
{
_renv_var
=
mvar
,
_renv_saver
=
saver
,
_renv_lock
=
lock
}
devJwkFile
::
FilePath
devJwkFile
=
"dev.jwk"
newEnv
::
PortNumber
->
FilePath
->
IO
Env
newEnv
port
file
=
do
manager
<-
newTlsManager
settings
<-
pure
(
devSettings
&
appPort
.~
port
)
-- TODO read from 'file'
settings
<-
devSettings
devJwkFile
<&>
appPort
.~
port
-- TODO read from 'file'
when
(
port
/=
settings
^.
appPort
)
$
panic
"TODO: conflicting settings of port"
...
...
@@ -295,10 +293,11 @@ withDevEnv iniPath k = do
param
<-
databaseParameters
iniPath
conn
<-
connect
param
repo
<-
readRepoEnv
setts
<-
devSettings
devJwkFile
pure
$
DevEnv
{
_dev_env_conn
=
conn
,
_dev_env_repo
=
repo
,
_dev_env_settings
=
devSetting
s
,
_dev_env_settings
=
sett
s
}
-- | Run Cmd Sugar for the Repl (GHCI)
...
...
src/Gargantext/API/Types.hs
View file @
09de17bd
...
...
@@ -10,13 +10,26 @@ Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module
Gargantext.API.Types
where
import
Control.Lens
(
Prism
'
,
(
#
))
import
Control.Lens.TH
(
makePrisms
)
import
Control.Monad.Error.Class
(
MonadError
(
throwError
))
import
Crypto.JOSE.Error
as
Jose
import
Data.Validity
import
Servant
import
Gargantext.Prelude
import
Gargantext.API.Settings
import
Gargantext.API.Ngrams
import
Gargantext.Database.Tree
...
...
@@ -24,18 +37,75 @@ import Gargantext.Core.Types
import
Gargantext.Database.Utils
import
Gargantext.Database.Schema.Node
class
HasServerError
e
where
_ServerError
::
Prism'
e
ServerError
type
GargServer
api
=
forall
env
err
m
.
serverError
::
(
MonadError
e
m
,
HasServerError
e
)
=>
ServerError
->
m
a
serverError
e
=
throwError
$
_ServerError
#
e
class
HasJoseError
e
where
_JoseError
::
Prism'
e
Jose
.
Error
joseError
::
(
MonadError
e
m
,
HasJoseError
e
)
=>
Jose
.
Error
->
m
a
joseError
=
throwError
.
(
_JoseError
#
)
class
ThrowAll'
e
a
|
a
->
e
where
-- | 'throwAll' is a convenience function to throw errors across an entire
-- sub-API
--
--
-- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
-- > == throwError err400 :<|> throwError err400 :<|> err400
throwAll'
::
e
->
a
instance
(
ThrowAll'
e
a
,
ThrowAll'
e
b
)
=>
ThrowAll'
e
(
a
:<|>
b
)
where
throwAll'
e
=
throwAll'
e
:<|>
throwAll'
e
-- Really this shouldn't be necessary - ((->) a) should be an instance of
-- MonadError, no?
instance
{-# OVERLAPPING #-}
ThrowAll'
e
b
=>
ThrowAll'
e
(
a
->
b
)
where
throwAll'
e
=
const
$
throwAll'
e
instance
{-# OVERLAPPABLE #-}
(
MonadError
e
m
)
=>
ThrowAll'
e
(
m
a
)
where
throwAll'
=
throwError
type
GargServerC
env
err
m
=
(
CmdM
env
err
m
,
HasNodeError
err
,
HasInvalidError
err
,
HasTreeError
err
,
HasServerError
err
,
HasJoseError
err
,
HasRepo
env
,
HasSettings
env
)
=>
ServerT
api
m
type
GargServerT
env
err
m
api
=
GargServerC
env
err
m
=>
ServerT
api
m
type
GargServer
api
=
forall
env
err
m
.
GargServerT
env
err
m
api
data
GargError
=
GargNodeError
NodeError
|
GargTreeError
TreeError
|
GargInvalidError
Validation
|
GargJoseError
Jose
.
Error
|
GargServerError
ServerError
deriving
(
Show
)
makePrisms
''
G
argError
instance
HasNodeError
GargError
where
_NodeError
=
_GargNodeError
instance
HasInvalidError
GargError
where
_InvalidError
=
_GargInvalidError
instance
HasTreeError
GargError
where
_TreeError
=
_GargTreeError
instance
HasServerError
GargError
where
_ServerError
=
_GargServerError
instance
HasJoseError
GargError
where
_JoseError
=
_GargJoseError
src/Gargantext/Database.hs
View file @
09de17bd
...
...
@@ -17,9 +17,9 @@ Gargantext's database.
{-# LANGUAGE NoImplicitPrelude #-}
module
Gargantext.Database
(
module
Gargantext
.
Database
.
Utils
,
module
Gargantext
.
Database
.
Bashql
--
, module Gargantext.Database.Bashql
)
where
import
Gargantext.Database.Utils
(
connectGargandb
)
import
Gargantext.Database.Bashql
--
import Gargantext.Database.Bashql
src/Gargantext/Database/Access.hs
View file @
09de17bd
...
...
@@ -7,6 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO-SECURITY review purpose of this module
-}
{-# LANGUAGE NoImplicitPrelude #-}
...
...
src/Gargantext/Database/Bashql.hs
View file @
09de17bd
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.Database.Bashql
Description : BASHQL to deal with Gargantext Database.
...
...
@@ -55,13 +56,15 @@ AMS, and by SIAM.
[3] https://github.com/Gabriel439/Haskell-Turtle-Library
TODO-ACCESS: should the checks be done here or before.
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module
Gargantext.Database.Bashql
(
get
module
Gargantext.Database.Bashql
(
)
{-(
get
,
ls
,
home
,
post
...
...
@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
,
rename
,
tree
--
,
mk
Corpus
,
mkAnnuaire
)
)
-
}
where
import
Control.Monad.Reader
-- (Reader, ask)
...
...
src/Gargantext/Database/Facet.hs
View file @
09de17bd
...
...
@@ -26,10 +26,22 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module
Gargantext.Database.Facet
(
runViewAuthorsDoc
,
runViewDocuments
,
filterWith
,
Pair
(
..
)
,
Facet
(
..
)
,
FacetDoc
,
FacetDocRead
,
FacetPaired
(
..
)
,
FacetPairedRead
,
OrderBy
(
..
)
)
where
------------------------------------------------------------------------
import
Control.Arrow
(
returnA
)
import
Control.Lens.TH
(
makeLensesWith
,
abbreviatedFields
)
--
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import
Data.Aeson
(
FromJSON
,
ToJSON
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Either
(
Either
(
Left
))
...
...
@@ -70,9 +82,9 @@ type Title = Text
-- TODO remove Title
type
FacetDoc
=
Facet
NodeId
UTCTime
Title
HyperdataDocument
(
Maybe
Favorite
)
(
Maybe
Double
)
type
FacetSources
=
FacetDoc
type
FacetAuthors
=
FacetDoc
type
FacetTerms
=
FacetDoc
--
type FacetSources = FacetDoc
--
type FacetAuthors = FacetDoc
--
type FacetTerms = FacetDoc
data
Facet
id
created
title
hyperdata
favorite
ngramCount
=
...
...
@@ -158,7 +170,7 @@ instance Arbitrary FacetDoc where
-- Facets / Views for the Front End
-- | Database instances
$
(
makeAdaptorAndInstance
"pFacetDoc"
''
F
acet
)
$
(
makeLensesWith
abbreviatedFields
''
F
acet
)
--
$(makeLensesWith abbreviatedFields ''Facet)
type
FacetDocRead
=
Facet
(
Column
PGInt4
)
(
Column
PGTimestamptz
)
...
...
@@ -196,6 +208,7 @@ instance Arbitrary OrderBy
arbitrary
=
elements
[
minBound
..
maxBound
]
-- TODO-SECURITY check
runViewAuthorsDoc
::
ContactId
->
IsTrash
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[
FacetDoc
]
runViewAuthorsDoc
cId
t
o
l
order
=
runOpaQuery
$
filterWith
o
l
order
$
viewAuthorsDoc
cId
t
ntId
where
...
...
@@ -236,6 +249,7 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
------------------------------------------------------------------------
-- TODO-SECURITY check
runViewDocuments
::
CorpusId
->
IsTrash
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[
FacetDoc
]
runViewDocuments
cId
t
o
l
order
=
runOpaQuery
$
filterWith
o
l
order
$
viewDocuments
cId
t
ntId
...
...
src/Gargantext/Database/Flow.hs
View file @
09de17bd
...
...
@@ -31,6 +31,13 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
module
Gargantext.Database.Flow
-- (flowDatabase, ngrams2list)
(
FlowCmdM
,
flowCorpusFile
,
flowCorpus
,
flowCorpusSearchInDatabase
,
getOrMkRoot
,
getOrMkRootWithCorpus
)
where
import
Prelude
(
String
)
import
Data.Either
...
...
@@ -45,7 +52,7 @@ import Data.Monoid
import
Data.Text
(
Text
,
splitOn
,
intercalate
)
import
GHC.Show
(
Show
)
import
Gargantext.API.Ngrams
(
HasRepoVar
)
import
Gargantext.API.Ngrams
(
NgramsElement
(
..
)
,
putListNgrams
,
RepoCmdM
)
import
Gargantext.API.Ngrams
(
NgramsElement
,
putListNgrams
,
RepoCmdM
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Types
(
NodePoly
(
..
),
Terms
(
..
))
import
Gargantext.Core.Types.Individu
(
Username
)
...
...
@@ -99,30 +106,32 @@ getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Noth
getDataApi
lang
limit
(
ApiIsidoreAuth
q
)
=
Isidore
.
get
lang
limit
Nothing
(
Just
q
)
flowCorpusApi
::
(
FlowCmdM
env
err
m
)
-- UNUSED
_flowCorpusApi
::
(
FlowCmdM
env
err
m
)
=>
Username
->
Either
CorpusName
[
CorpusId
]
->
TermType
Lang
->
Maybe
Limit
->
ApiQuery
->
m
CorpusId
flowCorpusApi
u
n
tt
l
q
=
do
_
flowCorpusApi
u
n
tt
l
q
=
do
docs
<-
liftIO
$
splitEvery
500
<$>
getDataApi
(
_tt_lang
tt
)
l
q
flowCorpus
u
n
tt
docs
------------------------------------------------------------------------
flowAnnuaire
::
FlowCmdM
env
err
m
-- UNUSED
_flowAnnuaire
::
FlowCmdM
env
err
m
=>
Username
->
Either
CorpusName
[
CorpusId
]
->
(
TermType
Lang
)
->
FilePath
->
m
AnnuaireId
flowAnnuaire
u
n
l
filePath
=
do
_
flowAnnuaire
u
n
l
filePath
=
do
docs
<-
liftIO
$
((
splitEvery
500
<$>
deserialiseImtUsersFromFile
filePath
)
::
IO
[[
HyperdataContact
]])
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
n
l
docs
flowCorpusDebat
::
FlowCmdM
env
err
m
-- UNUSED
_
flowCorpusDebat
::
FlowCmdM
env
err
m
=>
Username
->
Either
CorpusName
[
CorpusId
]
->
Limit
->
FilePath
->
m
CorpusId
flowCorpusDebat
u
n
l
fp
=
do
_
flowCorpusDebat
u
n
l
fp
=
do
docs
<-
liftIO
(
splitEvery
500
<$>
take
l
<$>
readFile'
fp
...
...
@@ -151,19 +160,22 @@ flowCorpusSearchInDatabase u la q = do
flowCorpusUser
la
u
(
Left
q
)
(
Nothing
::
Maybe
HyperdataCorpus
)
ids
flowCorpusSearchInDatabaseApi
::
FlowCmdM
env
err
m
-- UNUSED
_flowCorpusSearchInDatabaseApi
::
FlowCmdM
env
err
m
=>
Username
->
Lang
->
Text
->
m
CorpusId
flowCorpusSearchInDatabaseApi
u
la
q
=
do
_
flowCorpusSearchInDatabaseApi
u
la
q
=
do
(
_masterUserId
,
_masterRootId
,
cId
)
<-
getOrMkRootWithCorpus
userMaster
(
Left
""
)
(
Nothing
::
Maybe
HyperdataCorpus
)
ids
<-
map
fst
<$>
searchInDatabase
cId
(
stemIt
q
)
flowCorpusUser
la
u
(
Left
q
)
(
Nothing
::
Maybe
HyperdataCorpus
)
ids
------------------------------------------------------------------------
-- | TODO improve the needed type to create/update a corpus
{- UNUSED
data UserInfo = Username Text
| UserId NodeId
data CorpusInfo = CorpusName Lang Text
| CorpusId Lang NodeId
-}
flow
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
,
MkCorpus
c
)
...
...
src/Gargantext/Database/Flow/Pairing.hs
View file @
09de17bd
...
...
@@ -16,6 +16,7 @@ Portability : POSIX
-- {-# LANGUAGE Arrows #-}
module
Gargantext.Database.Flow.Pairing
(
pairing
)
where
--import Debug.Trace (trace)
...
...
src/Gargantext/Database/Node/Update.hs
View file @
09de17bd
...
...
@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
unOnly
::
Only
a
->
a
unOnly
(
Only
a
)
=
a
-- TODO-ACCESS
update
::
Update
->
Cmd
err
[
Int
]
update
(
Rename
nId
name
)
=
map
unOnly
<$>
runPGSQuery
"UPDATE nodes SET name=? where id=? returning id"
(
DT
.
take
255
name
,
nId
)
...
...
src/Gargantext/Database/TextSearch.hs
View file @
09de17bd
...
...
@@ -82,6 +82,7 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
type
AuthorName
=
Text
-- | TODO Optim: Offset and Limit in the Query
-- TODO-SECURITY check
searchInCorpusWithContacts
::
CorpusId
->
[
Text
]
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[
FacetPaired
Int
UTCTime
HyperdataDocument
Int
[
Pair
Int
Text
]]
searchInCorpusWithContacts
cId
q
o
l
order
=
take
(
maybe
5
identity
l
)
<$>
drop
(
maybe
0
identity
o
)
<$>
map
(
\
((
i
,
u
,
h
,
s
),
ps
)
->
FacetPaired
i
u
h
s
(
catMaybes
ps
))
...
...
@@ -94,6 +95,7 @@ searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop
maybePair
(
Pair
Nothing
_
)
=
Nothing
maybePair
(
Pair
(
Just
p_id
)
(
Just
p_label
))
=
Just
$
Pair
p_id
p_label
-- TODO-SECURITY check
searchInCorpusWithContacts'
::
CorpusId
->
[
Text
]
->
Maybe
Offset
->
Maybe
Limit
->
Maybe
OrderBy
->
Cmd
err
[(
FacetPaired
Int
UTCTime
HyperdataDocument
Int
(
Pair
(
Maybe
Int
)
(
Maybe
Text
)))]
searchInCorpusWithContacts'
cId
q
o
l
order
=
runOpaQuery
$
queryInCorpusWithContacts
cId
q'
o
l
order
where
...
...
src/Gargantext/Database/Types/Node.hs
View file @
09de17bd
...
...
@@ -41,9 +41,8 @@ import Data.ByteString.Lazy (ByteString)
import
Data.Either
import
Data.Eq
(
Eq
)
import
Data.Monoid
(
mempty
)
import
Data.Text
(
Text
,
unpack
,
pack
)
import
Data.Text
(
Text
,
unpack
)
import
Data.Time
(
UTCTime
)
import
Data.Time.Segment
(
jour
,
timesAfter
,
Granularity
(
D
))
import
Data.Swagger
import
Text.Read
(
read
)
...
...
@@ -55,6 +54,8 @@ import Servant
import
Test.QuickCheck.Arbitrary
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Instances.Time
()
import
Test.QuickCheck.Instances.Text
()
import
Gargantext.Prelude
import
Gargantext.Core.Utils.Prefix
(
unPrefix
)
...
...
@@ -133,12 +134,6 @@ type MasterUserId = UserId
id2int
::
NodeId
->
Int
id2int
(
NodeId
n
)
=
n
type
UTCTime'
=
UTCTime
instance
Arbitrary
UTCTime'
where
arbitrary
=
elements
$
timesAfter
100
D
(
jour
2000
01
01
)
------------------------------------------------------------------------
data
Status
=
Status
{
status_failed
::
!
Int
,
status_succeeded
::
!
Int
...
...
@@ -276,15 +271,13 @@ instance ToSchema Event where
declareNamedSchema
proxy
=
genericDeclareNamedSchema
defaultSchemaOptions
proxy
------------------------------------------------------------------------
instance
Arbitrary
Text
where
arbitrary
=
elements
$
map
(
\
c
->
pack
[
c
])
[
'a'
..
'z'
]
data
Resource
=
Resource
{
resource_path
::
!
(
Maybe
Text
)
,
resource_scraper
::
!
(
Maybe
Text
)
,
resource_query
::
!
(
Maybe
Text
)
,
resource_events
::
!
([
Event
])
,
resource_status
::
!
Status
,
resource_date
::
!
UTCTime
'
,
resource_date
::
!
UTCTime
}
deriving
(
Show
,
Generic
)
$
(
deriveJSON
(
unPrefix
"resource_"
)
''
R
esource
)
...
...
stack.yaml
View file @
09de17bd
...
...
@@ -6,7 +6,7 @@ packages:
docker
:
enable
:
false
repo
:
'
cgenie/stack-build:lts-12.26
'
repo
:
'
fpco/stack-build:lts-14.6-garg
'
allow-newer
:
true
extra-deps
:
...
...
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