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
148
Issues
148
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
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
gargantext
haskell-gargantext
Commits
9a23e2d1
Commit
9a23e2d1
authored
Apr 09, 2020
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[Flow] using user id. TODO : tests.
parent
75b4fd25
Pipeline
#811
failed with stage
Changes
15
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
161 additions
and
143 deletions
+161
-143
API.hs
src/Gargantext/API.hs
+19
-18
Auth.hs
src/Gargantext/API/Auth.hs
+2
-2
New.hs
src/Gargantext/API/Corpus/New.hs
+8
-8
Export.hs
src/Gargantext/API/Export.hs
+2
-1
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+1
-1
Node.hs
src/Gargantext/API/Node.hs
+2
-1
Types.hs
src/Gargantext/API/Types.hs
+1
-0
Types.hs
src/Gargantext/Core/Types.hs
+2
-0
Individu.hs
src/Gargantext/Core/Types/Individu.hs
+6
-1
Flow.hs
src/Gargantext/Database/Flow.hs
+34
-38
Types.hs
src/Gargantext/Database/Flow/Types.hs
+1
-1
Root.hs
src/Gargantext/Database/Root.hs
+21
-9
Node.hs
src/Gargantext/Database/Schema/Node.hs
+36
-47
User.hs
src/Gargantext/Database/Schema/User.hs
+24
-15
API.hs
src/Gargantext/Viz/Graph/API.hs
+2
-1
No files found.
src/Gargantext/API.hs
View file @
9a23e2d1
...
...
@@ -53,26 +53,15 @@ import Control.Lens
import
Control.Monad.Except
(
withExceptT
,
ExceptT
)
import
Control.Monad.Reader
(
ReaderT
,
runReaderT
)
import
Data.Aeson.Encode.Pretty
(
encodePretty
)
import
Data.List
(
lookup
)
import
Data.Swagger
import
Data.Text
(
Text
)
import
Data.Text.Encoding
(
encodeUtf8
)
import
Data.Validity
import
Data.Version
(
showVersion
)
import
GHC.Base
(
Applicative
)
import
GHC.Generics
(
D1
,
Meta
(
..
),
Rep
)
import
GHC.TypeLits
(
AppendSymbol
,
Symbol
)
import
Network.Wai
import
Network.Wai.Handler.Warp
hiding
(
defaultSettings
)
import
qualified
Paths_gargantext
as
PG
-- cabal magic build module
import
Servant
import
Servant.Auth
as
SA
import
Servant.Auth.Server
(
AuthResult
(
..
))
import
Servant.Auth.Swagger
()
import
Servant.Job.Async
import
Servant.Swagger
import
Servant.Swagger.UI
import
System.IO
(
FilePath
)
import
Data.List
(
lookup
)
import
Data.Text.Encoding
(
encodeUtf8
)
import
GHC.Base
(
Applicative
)
import
Gargantext.API.Auth
(
AuthRequest
,
AuthResponse
,
AuthenticatedUser
(
..
),
AuthContext
,
auth
,
withAccess
,
PathId
(
..
))
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
Gargantext.API.FrontEnd
(
FrontEndAPI
,
frontEndServer
)
...
...
@@ -82,6 +71,7 @@ import Gargantext.API.Orchestrator.Types
import
Gargantext.API.Search
(
SearchPairsAPI
,
searchPairs
)
import
Gargantext.API.Settings
import
Gargantext.API.Types
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Node.Contact
(
HyperdataContact
)
import
Gargantext.Database.Types.Node
import
Gargantext.Database.Types.Node
(
NodeId
,
CorpusId
,
AnnuaireId
)
...
...
@@ -89,9 +79,20 @@ import Gargantext.Database.Utils (HasConnectionPool)
import
Gargantext.Prelude
import
Gargantext.Viz.Graph.API
import
Network.HTTP.Types
hiding
(
Query
)
import
Network.Wai
import
Network.Wai
(
Request
,
requestHeaders
)
import
Network.Wai.Handler.Warp
hiding
(
defaultSettings
)
import
Network.Wai.Middleware.Cors
import
Network.Wai.Middleware.RequestLogger
import
Servant
import
Servant.Auth
as
SA
import
Servant.Auth.Server
(
AuthResult
(
..
))
import
Servant.Auth.Swagger
()
import
Servant.Job.Async
import
Servant.Swagger
import
Servant.Swagger.UI
import
System.IO
(
FilePath
)
import
qualified
Paths_gargantext
as
PG
-- cabal magic build module
import
qualified
Data.ByteString.Lazy.Char8
as
BL8
import
qualified
Data.Text.IO
as
T
import
qualified
Gargantext.API.Annuaire
as
Annuaire
...
...
@@ -405,7 +406,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
-- TODO access
-- :<|> addUpload
-- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
:<|>
addCorpusWithForm
"user1"
:<|>
addCorpusWithForm
(
UserDBId
uid
)
--
"user1"
:<|>
addCorpusWithQuery
:<|>
addAnnuaireWithForm
...
...
@@ -431,15 +432,15 @@ addWithFile cid i f =
serveJobsAPI
$
JobFunction
(
\
_i
log
->
New
.
addToCorpusWithFile
cid
i
f
(
liftBase
.
log
))
addCorpusWithForm
::
Text
->
GargServer
New
.
AddWithForm
addCorpusWithForm
user
name
cid
=
addCorpusWithForm
::
User
->
GargServer
New
.
AddWithForm
addCorpusWithForm
user
cid
=
serveJobsAPI
$
JobFunction
(
\
i
log
->
let
log'
x
=
do
printDebug
"addCorpusWithForm"
x
liftBase
$
log
x
in
New
.
addToCorpusWithForm
user
name
cid
i
log'
)
in
New
.
addToCorpusWithForm
user
cid
i
log'
)
addAnnuaireWithForm
::
GargServer
Annuaire
.
AddWithForm
addAnnuaireWithForm
cid
=
...
...
src/Gargantext/API/Auth.hs
View file @
9a23e2d1
...
...
@@ -53,7 +53,7 @@ import Gargantext.Database.Utils (Cmd', CmdM, HasConnectionPool)
import
Gargantext.Prelude
hiding
(
reverse
)
import
Test.QuickCheck
(
elements
,
oneof
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
import
Gargantext.Core.Types.Individu
(
Username
,
Password
,
arbitraryUsername
,
arbitraryPassword
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
User
name
,
Password
,
arbitraryUsername
,
arbitraryPassword
)
---------------------------------------------------
...
...
@@ -101,7 +101,7 @@ checkAuthRequest u p
|
not
(
u
`
elem
`
arbitraryUsername
)
=
pure
InvalidUser
|
u
/=
reverse
p
=
pure
InvalidPassword
|
otherwise
=
do
muId
<-
head
<$>
getRoot
u
muId
<-
head
<$>
getRoot
(
UserName
u
)
case
_node_id
<$>
muId
of
Nothing
->
pure
InvalidUser
Just
uid
->
do
...
...
src/Gargantext/API/Corpus/New.hs
View file @
9a23e2d1
...
...
@@ -42,7 +42,7 @@ import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
import
Gargantext.Database.Flow
(
flowCorpusSearchInDatabase
)
import
Gargantext.Database.Types.Node
(
CorpusId
)
import
Gargantext.Database.Types.Node
(
ToHyperdataDocument
(
..
))
import
Gargantext.
Database.Types.Node
(
UserId
)
import
Gargantext.
Core.Types.Individu
(
UserId
,
User
(
..
)
)
import
Gargantext.Prelude
import
qualified
Gargantext.Text.Corpus.Parsers
as
Parser
(
FileFormat
(
..
),
parseFormat
)
import
Gargantext.Text.Terms
(
TermType
(
..
))
...
...
@@ -89,13 +89,13 @@ type GetApi = Get '[JSON] ApiInfo
-- TODO-ACCESS
-- TODO this is only the POST
api
::
(
FlowCmdM
env
err
m
)
=>
UserId
->
Query
->
m
CorpusId
api
_uI
d
(
Query
q
_
as
)
=
do
api
ui
d
(
Query
q
_
as
)
=
do
cId
<-
case
head
as
of
Nothing
->
flowCorpusSearchInDatabase
"user1"
EN
q
Just
API
.
All
->
flowCorpusSearchInDatabase
"user1"
EN
q
Nothing
->
flowCorpusSearchInDatabase
(
UserDBId
uid
)
EN
q
Just
API
.
All
->
flowCorpusSearchInDatabase
(
UserDBId
uid
)
EN
q
Just
a
->
do
docs
<-
liftBase
$
API
.
get
a
q
(
Just
1000
)
cId'
<-
flowCorpus
"user1"
(
Left
q
)
(
Multi
EN
)
[
docs
]
cId'
<-
flowCorpus
(
UserDBId
uid
)
(
Left
q
)
(
Multi
EN
)
[
docs
]
pure
cId'
pure
cId
...
...
@@ -240,12 +240,12 @@ addToCorpusWithForm' cid (WithForm ft d l) logStatus = do
pure s'
-}
addToCorpusWithForm
::
FlowCmdM
env
err
m
=>
Text
=>
User
->
CorpusId
->
WithForm
->
(
ScraperStatus
->
m
()
)
->
m
ScraperStatus
addToCorpusWithForm
user
name
cid
(
WithForm
ft
d
l
_n
)
logStatus
=
do
addToCorpusWithForm
user
cid
(
WithForm
ft
d
l
_n
)
logStatus
=
do
let
parse
=
case
ft
of
...
...
@@ -271,7 +271,7 @@ addToCorpusWithForm username cid (WithForm ft d l _n) logStatus = do
printDebug
"Starting extraction : "
cid
-- TODO granularity of the logStatus
_cid'
<-
flowCorpus
user
name
_cid'
<-
flowCorpus
user
(
Right
[
cid
])
(
Multi
$
fromMaybe
EN
l
)
(
map
(
map
toHyperdataDocument
)
docs
)
...
...
src/Gargantext/API/Export.hs
View file @
9a23e2d1
...
...
@@ -41,7 +41,8 @@ import Gargantext.Database.Config (userMaster)
import
Gargantext.Database.Metrics.NgramsByNode
(
getNgramsByNodeOnlyUser
)
import
Gargantext.Database.Node.Select
(
selectNodesWithUsername
)
import
Gargantext.Database.Schema.Ngrams
(
NgramsType
(
..
))
import
Gargantext.Database.Schema.Node
(
defaultList
,
HasNodeError
)
import
Gargantext.Database.Schema.Node
(
defaultList
)
import
Gargantext.Database.Types.Errors
(
HasNodeError
)
import
Gargantext.Database.Schema.NodeNode
(
selectDocNodes
)
import
Gargantext.Database.Types.Node
(
Node
,
HyperdataDocument
(
..
),
NodeId
,
ListId
,
CorpusId
)
import
Gargantext.Database.Utils
(
Cmd
)
...
...
src/Gargantext/API/Ngrams.hs
View file @
9a23e2d1
...
...
@@ -146,7 +146,7 @@ import Gargantext.Database.Utils (fromField', HasConnectionPool)
import
Gargantext.Database.Node.Select
import
Gargantext.Database.Ngrams
--import Gargantext.Database.Lists (listsWith)
import
Gargantext.Database.
Schema.Node
(
HasNodeError
)
import
Gargantext.Database.
Types.Errors
(
HasNodeError
)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
)
import
qualified
Gargantext.Database.Schema.Ngrams
as
Ngrams
-- import Gargantext.Database.Schema.NodeNgram hiding (Action)
...
...
src/Gargantext/API/Node.hs
View file @
9a23e2d1
...
...
@@ -58,10 +58,11 @@ import Gargantext.Database.Flow.Pairing (pairing)
import
Gargantext.Database.Facet
(
FacetDoc
,
OrderBy
(
..
))
import
Gargantext.Database.Node.Children
(
getChildren
)
import
Gargantext.Database.Node.User
(
NodeUser
)
import
Gargantext.Database.Schema.Node
(
getNodesWithParentId
,
getNodeWith
,
getNode
,
deleteNode
,
deleteNodes
,
mkNodeWithParent
,
JSONB
,
HasNodeError
(
..
),
getNodeUser
)
import
Gargantext.Database.Schema.Node
(
getNodesWithParentId
,
getNodeWith
,
getNode
,
deleteNode
,
deleteNodes
,
mkNodeWithParent
,
JSONB
,
getNodeUser
)
import
Gargantext.Database.Schema.NodeNode
-- (nodeNodesCategory, insertNodeNode, NodeNode(..))
import
Gargantext.Database.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Tree
(
treeDB
)
import
Gargantext.Database.Types.Errors
(
HasNodeError
(
..
))
import
Gargantext.Database.Types.Node
import
Gargantext.Database.Utils
-- (Cmd, CmdM)
import
Gargantext.Prelude
...
...
src/Gargantext/API/Types.hs
View file @
9a23e2d1
...
...
@@ -45,6 +45,7 @@ import Gargantext.API.Settings
import
Gargantext.API.Orchestrator.Types
import
Gargantext.API.Ngrams
import
Gargantext.Core.Types
import
Gargantext.Database.Types.Errors
(
NodeError
(
..
),
HasNodeError
(
..
))
import
Gargantext.Database.Tree
import
Gargantext.Database.Utils
import
Gargantext.Database.Schema.Node
...
...
src/Gargantext/Core/Types.hs
View file @
9a23e2d1
...
...
@@ -164,5 +164,7 @@ data TODO = TODO
instance
ToSchema
TODO
where
instance
ToParamSchema
TODO
where
----------------------------------------------------------------------------
src/Gargantext/Core/Types/Individu.hs
View file @
9a23e2d1
...
...
@@ -20,6 +20,12 @@ module Gargantext.Core.Types.Individu
import
Gargantext.Prelude
hiding
(
reverse
)
import
Data.Text
(
Text
,
pack
,
reverse
)
import
Gargantext.Database.Types.Node
(
NodeId
)
type
UserId
=
Int
data
User
=
UserDBId
UserId
|
UserName
Text
deriving
(
Eq
)
type
Username
=
Text
type
Password
=
Text
...
...
@@ -38,4 +44,3 @@ arbitraryPassword :: [Password]
arbitraryPassword
=
map
reverse
arbitraryUsername
src/Gargantext/Database/Flow.hs
View file @
9a23e2d1
...
...
@@ -38,53 +38,53 @@ module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
)
where
import
Prelude
(
String
)
import
Data.Either
import
Data.Tuple.Extra
(
first
,
second
)
import
Data.Traversable
(
traverse
)
import
Debug.Trace
(
trace
)
import
Control.Lens
((
^.
),
view
,
_Just
)
import
Data.Either
import
Data.List
(
concat
)
import
Data.Map
(
Map
,
lookup
)
import
Data.Maybe
(
Maybe
(
..
),
catMaybes
)
import
Data.Monoid
import
Data.Text
(
Text
,
splitOn
,
intercalate
)
import
Data.Traversable
(
traverse
)
import
Data.Tuple.Extra
(
first
,
second
)
import
Debug.Trace
(
trace
)
import
Gargantext.Core
(
Lang
(
..
))
import
Gargantext.Core.Types
(
NodePoly
(
..
),
Terms
(
..
))
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Core.Flow.Types
import
Gargantext.Core.Types
(
NodePoly
(
..
),
Terms
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Main
import
Gargantext.Database.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Flow.Utils
(
insertDocNgrams
)
import
Gargantext.Database.Flow.List
import
Gargantext.Database.Flow.Types
import
Gargantext.Database.Flow.Utils
(
insertDocNgrams
)
import
Gargantext.Database.Node.Contact
-- (HyperdataContact(..), ContactWho(..))
import
Gargantext.Database.Node.Document.Insert
-- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import
Gargantext.Database.Root
(
getRoot
)
import
Gargantext.Database.Schema.Ngrams
-- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
import
Gargantext.Database.Schema.Node
-- (mkRoot, mkCorpus, getOrMkList, mkGraph, {-mkPhylo,-} mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
import
Gargantext.Database.Schema.NodeNgrams
(
listInsertDb
,
getCgramsId
)
import
Gargantext.Database.Schema.NodeNodeNgrams2
-- (NodeNodeNgrams2, insertNodeNodeNgrams2)
import
Gargantext.Database.Schema.User
(
getUser
,
UserLight
(
..
)
)
import
Gargantext.Database.Schema.User
(
getUser
Id
)
import
Gargantext.Database.TextSearch
(
searchInDatabase
)
import
Gargantext.Database.Types.Errors
(
HasNodeError
(
..
),
NodeError
(
..
),
nodeError
)
import
Gargantext.Database.Types.Node
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import
Gargantext.Database.Utils
(
Cmd
)
import
Gargantext.Ext.IMT
(
toSchoolName
)
import
Gargantext.Ext.IMTUser
(
deserialiseImtUsersFromFile
)
import
Gargantext.Prelude
import
Gargantext.Text.Terms.Eleve
(
buildTries
,
toToken
)
import
Gargantext.Text.List
(
buildNgramsLists
,
StopSize
(
..
))
import
Gargantext.Prelude.Utils
hiding
(
sha
)
import
Gargantext.Text.Corpus.Parsers
(
parseFile
,
FileFormat
)
import
qualified
Gargantext.Text.Corpus.API.Isidore
as
Isidore
import
Gargantext.Text.List
(
buildNgramsLists
,
StopSize
(
..
))
import
Gargantext.Text.Terms
(
TermType
(
..
),
tt_lang
,
extractTerms
,
uniText
)
import
Gargantext.Text.Terms.Eleve
(
buildTries
,
toToken
)
import
Gargantext.Text.Terms.Mono.Stem.En
(
stemIt
)
import
Gargantext.Prelude.Utils
hiding
(
sha
)
import
Prelude
(
String
)
import
System.FilePath
(
FilePath
)
import
qualified
Data.List
as
List
import
qualified
Data.Map
as
Map
import
qualified
Data.Text
as
Text
import
qualified
Gargantext.Database.Node.Document.Add
as
Doc
(
add
)
import
qualified
Gargantext.Text.Corpus.API.Isidore
as
Isidore
import
qualified
Gargantext.Text.Corpus.Parsers.GrandDebat
as
GD
------------------------------------------------------------------------
...
...
@@ -102,7 +102,7 @@ getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Jus
-- UNUSED
_flowCorpusApi
::
(
FlowCmdM
env
err
m
)
=>
User
name
->
Either
CorpusName
[
CorpusId
]
=>
User
->
Either
CorpusName
[
CorpusId
]
->
TermType
Lang
->
Maybe
Limit
->
ApiQuery
...
...
@@ -114,7 +114,7 @@ _flowCorpusApi u n tt l q = do
------------------------------------------------------------------------
flowAnnuaire
::
FlowCmdM
env
err
m
=>
User
name
=>
User
->
Either
CorpusName
[
CorpusId
]
->
(
TermType
Lang
)
->
FilePath
...
...
@@ -125,7 +125,7 @@ flowAnnuaire u n l filePath = do
-- UNUSED
_flowCorpusDebat
::
FlowCmdM
env
err
m
=>
User
name
->
Either
CorpusName
[
CorpusId
]
=>
User
->
Either
CorpusName
[
CorpusId
]
->
Limit
->
FilePath
->
m
CorpusId
_flowCorpusDebat
u
n
l
fp
=
do
...
...
@@ -137,7 +137,7 @@ _flowCorpusDebat u n l fp = do
flowCorpus
u
n
(
Multi
FR
)
(
map
(
map
toHyperdataDocument
)
docs
)
flowCorpusFile
::
FlowCmdM
env
err
m
=>
User
name
->
Either
CorpusName
[
CorpusId
]
=>
User
->
Either
CorpusName
[
CorpusId
]
->
Limit
-- Limit the number of docs (for dev purpose)
->
TermType
Lang
->
FileFormat
->
FilePath
->
m
CorpusId
...
...
@@ -150,13 +150,13 @@ flowCorpusFile u n l la ff fp = do
-- TODO query with complex query
flowCorpusSearchInDatabase
::
FlowCmdM
env
err
m
=>
User
name
=>
User
->
Lang
->
Text
->
m
CorpusId
flowCorpusSearchInDatabase
u
la
q
=
do
(
_masterUserId
,
_masterRootId
,
cId
)
<-
getOrMk_RootWithCorpus
userMaster
(
UserName
userMaster
)
(
Left
""
)
(
Nothing
::
Maybe
HyperdataCorpus
)
ids
<-
map
fst
<$>
searchInDatabase
cId
(
stemIt
q
)
...
...
@@ -165,13 +165,13 @@ flowCorpusSearchInDatabase u la q = do
-- UNUSED
_flowCorpusSearchInDatabaseApi
::
FlowCmdM
env
err
m
=>
User
name
=>
User
->
Lang
->
Text
->
m
CorpusId
_flowCorpusSearchInDatabaseApi
u
la
q
=
do
(
_masterUserId
,
_masterRootId
,
cId
)
<-
getOrMk_RootWithCorpus
userMaster
(
UserName
userMaster
)
(
Left
""
)
(
Nothing
::
Maybe
HyperdataCorpus
)
ids
<-
map
fst
<$>
searchInDatabase
cId
(
stemIt
q
)
...
...
@@ -188,7 +188,7 @@ data CorpusInfo = CorpusName Lang Text
flow
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
,
MkCorpus
c
)
=>
Maybe
c
->
User
name
->
User
->
Either
CorpusName
[
CorpusId
]
->
TermType
Lang
->
[[
a
]]
...
...
@@ -198,7 +198,7 @@ flow c u cn la docs = do
flowCorpusUser
(
la
^.
tt_lang
)
u
cn
c
(
concat
ids
)
flowCorpus
::
(
FlowCmdM
env
err
m
,
FlowCorpus
a
)
=>
User
name
=>
User
->
Either
CorpusName
[
CorpusId
]
->
TermType
Lang
->
[[
a
]]
...
...
@@ -208,7 +208,7 @@ flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
------------------------------------------------------------------------
flowCorpusUser
::
(
FlowCmdM
env
err
m
,
MkCorpus
c
)
=>
Lang
->
User
name
->
User
->
Either
CorpusName
[
CorpusId
]
->
Maybe
c
->
[
NodeId
]
...
...
@@ -225,7 +225,7 @@ flowCorpusUser l userName corpusName ctype ids = do
-- printDebug "Node Text Id" tId
-- User List Flow
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
userMaster
(
Left
""
)
ctype
(
masterUserId
,
_masterRootId
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
""
)
ctype
ngs
<-
buildNgramsLists
l
2
3
(
StopSize
3
)
userCorpusId
masterCorpusId
_userListId
<-
flowList_DbRepo
listId
ngs
_mastListId
<-
getOrMkList
masterCorpusId
masterUserId
...
...
@@ -250,7 +250,7 @@ insertMasterDocs :: ( FlowCmdM env err m
->
[
a
]
->
m
[
DocId
]
insertMasterDocs
c
lang
hs
=
do
(
masterUserId
,
_
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
userMaster
(
Left
corpusMasterName
)
c
(
masterUserId
,
_
,
masterCorpusId
)
<-
getOrMk_RootWithCorpus
(
UserName
userMaster
)
(
Left
corpusMasterName
)
c
-- TODO Type NodeDocumentUnicised
let
docs
=
map
addUniqId
hs
...
...
@@ -314,20 +314,16 @@ withLang l _ = l
type
CorpusName
=
Text
getOrMkRoot
::
(
HasNodeError
err
)
=>
User
name
=>
User
->
Cmd
err
(
UserId
,
RootId
)
getOrMkRoot
username
=
do
maybeUserId
<-
getUser
username
userId
<-
case
maybeUserId
of
Nothing
->
nodeError
NoUserFound
Just
user
->
pure
$
userLight_id
user
getOrMkRoot
user
=
do
userId
<-
getUserId
user
rootId'
<-
map
_node_id
<$>
getRoot
user
name
rootId'
<-
map
_node_id
<$>
getRoot
user
rootId''
<-
case
rootId'
of
[]
->
mkRoot
user
name
userId
[]
->
mkRoot
user
n
->
case
length
n
>=
2
of
True
->
nodeError
ManyNodeUsers
False
->
pure
rootId'
...
...
@@ -337,13 +333,13 @@ getOrMkRoot username = do
getOrMk_RootWithCorpus
::
(
HasNodeError
err
,
MkCorpus
a
)
=>
User
name
=>
User
->
Either
CorpusName
[
CorpusId
]
->
Maybe
a
->
Cmd
err
(
UserId
,
RootId
,
CorpusId
)
getOrMk_RootWithCorpus
username
cName
c
=
do
(
userId
,
rootId
)
<-
getOrMkRoot
username
corpusId''
<-
if
username
==
userMaster
corpusId''
<-
if
username
==
UserName
userMaster
then
do
ns
<-
getCorporaWithParentId
rootId
pure
$
map
_node_id
ns
...
...
src/Gargantext/Database/Flow/Types.hs
View file @
9a23e2d1
...
...
@@ -30,7 +30,7 @@ import Gargantext.Core.Flow.Types
import
Gargantext.API.Ngrams
(
HasRepoVar
,
RepoCmdM
)
import
Gargantext.Database.Schema.Ngrams
(
Ngrams
(
..
),
NgramsType
(
..
))
import
Gargantext.Database.Types.Node
(
NodeId
)
import
Gargantext.Database.
Schema.Node
(
HasNodeError
)
import
Gargantext.Database.
Types.Errors
(
HasNodeError
)
import
Gargantext.Database.Utils
(
CmdM
)
type
FlowCmdM
env
err
m
=
...
...
src/Gargantext/Database/Root.hs
View file @
9a23e2d1
...
...
@@ -26,24 +26,25 @@ Portability : POSIX
module
Gargantext.Database.Root
where
import
Opaleye
(
restrict
,
(
.==
),
Query
)
import
Opaleye.PGTypes
(
pgStrictText
,
pgInt4
)
import
Control.Arrow
(
returnA
)
import
Gargantext.
Prelude
import
Gargantext.Database.
Types.Node
(
Node
,
NodePoly
(
..
),
NodeType
(
NodeUser
)
)
import
Gargantext.
Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.
Config
(
nodeTypeId
)
import
Gargantext.Database.Node.User
(
HyperdataUser
)
import
Gargantext.Database.Schema.Node
(
NodeRead
)
import
Gargantext.Database.Schema.Node
(
pgNodeId
)
import
Gargantext.Database.Schema.Node
(
queryNodeTable
)
import
Gargantext.Database.Schema.User
(
queryUserTable
,
UserPoly
(
..
))
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Database.Types.Node
(
Node
,
NodePoly
(
..
),
NodeType
(
NodeUser
))
import
Gargantext.Database.Utils
(
Cmd
,
runOpaQuery
)
import
Gargantext.Prelude
import
Opaleye
(
restrict
,
(
.==
),
Query
)
import
Opaleye.PGTypes
(
pgStrictText
,
pgInt4
)
getRoot
::
User
name
->
Cmd
err
[
Node
HyperdataUser
]
getRoot
::
User
->
Cmd
err
[
Node
HyperdataUser
]
getRoot
=
runOpaQuery
.
selectRoot
selectRoot
::
User
name
->
Query
NodeRead
selectRoot
username
=
proc
()
->
do
selectRoot
::
User
->
Query
NodeRead
selectRoot
(
UserName
username
)
=
proc
()
->
do
row
<-
queryNodeTable
-<
()
users
<-
queryUserTable
-<
()
restrict
-<
_node_typename
row
.==
(
pgInt4
$
nodeTypeId
NodeUser
)
...
...
@@ -51,4 +52,15 @@ selectRoot username = proc () -> do
restrict
-<
_node_userId
row
.==
(
user_id
users
)
returnA
-<
row
selectRoot
(
UserDBId
uid
)
=
proc
()
->
do
row
<-
queryNodeTable
-<
()
restrict
-<
_node_typename
row
.==
(
pgInt4
$
nodeTypeId
NodeUser
)
restrict
-<
_node_userId
row
.==
(
pgInt4
uid
)
returnA
-<
row
src/Gargantext/Database/Schema/Node.hs
View file @
9a23e2d1
...
...
@@ -37,12 +37,14 @@ import Data.Text (Text)
import
Database.PostgreSQL.Simple.FromField
(
FromField
,
fromField
)
import
GHC.Int
(
Int64
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Database.Types.Errors
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Database.Queries.Filter
(
limit'
,
offset'
)
import
Gargantext.Database.Types.Node
(
NodeType
(
..
),
defaultCorpus
,
Hyperdata
,
HyperData
(
..
))
import
Gargantext.Database.Node.User
(
HyperdataUser
(
..
),
fake_HyperdataUser
)
import
Gargantext.Database.Node.Contact
(
HyperdataContact
(
..
),
arbitraryHyperdataContact
)
import
Gargantext.Database.Schema.User
(
getUserId
)
import
Gargantext.Database.Utils
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
Gargantext.Viz.Graph
(
HyperdataGraph
(
..
))
...
...
@@ -51,30 +53,6 @@ import Opaleye hiding (FromField)
import
Opaleye.Internal.QueryArr
(
Query
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
------------------------------------------------------------------------
data
NodeError
=
NoListFound
|
NoRootFound
|
NoCorpusFound
|
NoUserFound
|
MkNode
|
UserNoParent
|
HasParent
|
ManyParents
|
NegativeId
|
NotImplYet
|
ManyNodeUsers
deriving
(
Show
)
class
HasNodeError
e
where
_NodeError
::
Prism'
e
NodeError
nodeError
::
(
MonadError
e
m
,
HasNodeError
e
)
=>
NodeError
->
m
a
nodeError
ne
=
throwError
$
_NodeError
#
ne
catchNodeError
::
(
MonadError
e
m
,
HasNodeError
e
)
=>
m
a
->
(
NodeError
->
m
a
)
->
m
a
catchNodeError
f
g
=
catchError
f
(
\
e
->
maybe
(
throwError
e
)
g
(
e
^?
_NodeError
))
------------------------------------------------------------------------
instance
FromField
HyperdataAny
where
fromField
=
fromField'
...
...
@@ -637,36 +615,41 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
-- =================================================================== --
------------------------------------------------------------------------
-- | TODO mk all others nodes
mkNodeWithParent
::
HasNodeError
err
=>
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
err
[
NodeId
]
mkNodeWithParent
::
HasNodeError
err
=>
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
err
[
NodeId
]
mkNodeWithParent
NodeUser
(
Just
_
)
_
_
=
nodeError
UserNoParent
------------------------------------------------------------------------
mkNodeWithParent
NodeUser
Nothing
uId
name
=
mkNodeWithParent
NodeUser
Nothing
uId
name
=
insertNodesWithParentR
Nothing
[
node
NodeUser
name
fake_HyperdataUser
Nothing
uId
]
mkNodeWithParent
_
Nothing
_
_
=
nodeError
HasParent
------------------------------------------------------------------------
mkNodeWithParent
NodeFolder
(
Just
i
)
uId
name
=
mkNodeWithParent
NodeFolder
(
Just
i
)
uId
name
=
insertNodesWithParentR
(
Just
i
)
[
node
NodeFolder
name
hd
Nothing
uId
]
where
hd
=
defaultFolder
mkNodeWithParent
NodeFolderPrivate
(
Just
i
)
uId
_
=
mkNodeWithParent
NodeFolderPrivate
(
Just
i
)
uId
_
=
insertNodesWithParentR
(
Just
i
)
[
node
NodeFolderPrivate
"Private"
hd
Nothing
uId
]
where
hd
=
defaultFolder
mkNodeWithParent
NodeFolderShared
(
Just
i
)
uId
_
=
mkNodeWithParent
NodeFolderShared
(
Just
i
)
uId
_
=
insertNodesWithParentR
(
Just
i
)
[
node
NodeFolderShared
"Shared"
hd
Nothing
uId
]
where
hd
=
defaultFolder
mkNodeWithParent
NodeFolderPublic
(
Just
i
)
uId
_
=
mkNodeWithParent
NodeFolderPublic
(
Just
i
)
uId
_
=
insertNodesWithParentR
(
Just
i
)
[
node
NodeFolderPublic
"Public"
hd
Nothing
uId
]
where
hd
=
defaultFolder
mkNodeWithParent
NodeTeam
(
Just
i
)
uId
_
=
mkNodeWithParent
NodeTeam
(
Just
i
)
uId
_
=
insertNodesWithParentR
(
Just
i
)
[
node
NodeTeam
"Team"
hd
Nothing
uId
]
where
hd
=
defaultFolder
...
...
@@ -685,21 +668,27 @@ mkNodeWithParent _ _ _ _ = nodeError NotImplYet
------------------------------------------------------------------------
-- =================================================================== --
mkRoot
::
HasNodeError
err
=>
Username
->
UserId
->
Cmd
err
[
RootId
]
mkRoot
uname
uId
=
case
uId
>
0
of
False
->
nodeError
NegativeId
True
->
do
rs
<-
mkNodeWithParent
NodeUser
Nothing
uId
uname
_
<-
case
rs
of
[
r
]
->
do
_
<-
mkNodeWithParent
NodeFolderPrivate
(
Just
r
)
uId
uname
_
<-
mkNodeWithParent
NodeFolderShared
(
Just
r
)
uId
uname
_
<-
mkNodeWithParent
NodeFolderPublic
(
Just
r
)
uId
uname
pure
rs
_
->
pure
rs
pure
rs
mkRoot
::
HasNodeError
err
=>
User
->
Cmd
err
[
RootId
]
mkRoot
user
=
do
uid
<-
getUserId
user
let
una
=
"username"
case
uid
>
0
of
False
->
nodeError
NegativeId
True
->
do
rs
<-
mkNodeWithParent
NodeUser
Nothing
uid
una
_
<-
case
rs
of
[
r
]
->
do
_
<-
mkNodeWithParent
NodeFolderPrivate
(
Just
r
)
uid
una
_
<-
mkNodeWithParent
NodeFolderShared
(
Just
r
)
uid
una
_
<-
mkNodeWithParent
NodeFolderPublic
(
Just
r
)
uid
una
pure
rs
_
->
pure
rs
pure
rs
-- |
-- CorpusDocument is a corpus made from a set of documents
...
...
src/Gargantext/Database/Schema/User.hs
View file @
9a23e2d1
...
...
@@ -34,27 +34,26 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import
Data.Text
(
Text
)
import
Data.Time
(
UTCTime
)
import
GHC.Show
(
Show
(
..
))
import
Gargantext.Core.Types.Individu
(
Username
,
arbitraryUsername
)
import
Gargantext.Core.Types.Individu
(
Username
,
arbitraryUsername
,
User
(
..
),
UserId
)
import
Gargantext.Database.Types.Errors
import
Gargantext.Database.Utils
import
Gargantext.Prelude
import
Opaleye
------------------------------------------------------------------------
------------------------------------------------------------------------
type
UserId
=
Int
data
UserLight
=
UserLight
{
userLight_id
::
Int
,
userLight_username
::
Text
,
userLight_email
::
Text
}
deriving
(
Show
)
toUserLight
::
User
->
UserLight
toUserLight
(
User
id
_
_
_
u
_
_
e
_
_
_
)
=
UserLight
id
u
e
toUserLight
::
User
DB
->
UserLight
toUserLight
(
User
DB
id
_
_
_
u
_
_
e
_
_
_
)
=
UserLight
id
u
e
data
UserPoly
id
pass
llogin
suser
uname
fname
lname
mail
staff
active
djoined
=
User
{
user_id
::
id
mail
staff
active
djoined
=
User
DB
{
user_id
::
id
,
user_password
::
pass
,
user_lastLogin
::
llogin
,
user_isSuperUser
::
suser
...
...
@@ -93,14 +92,14 @@ type UserReadNull = UserPoly (Column (Nullable PGInt4)) (Column (Nul
type
User
=
UserPoly
Int
Text
(
Maybe
UTCTime
)
Bool
Text
Text
Text
Text
Bool
Bool
UTCTime
type
User
DB
=
UserPoly
Int
Text
(
Maybe
UTCTime
)
Bool
Text
Text
Text
Text
Bool
Bool
UTCTime
$
(
makeAdaptorAndInstance
"pUser
"
''
U
serPoly
)
$
(
makeAdaptorAndInstance
"pUser
DB"
''
U
serPoly
)
$
(
makeLensesWith
abbreviatedFields
''
U
serPoly
)
userTable
::
Table
UserWrite
UserRead
userTable
=
Table
"auth_user"
(
pUser
User
{
user_id
=
optional
"id"
userTable
=
Table
"auth_user"
(
pUser
DB
UserDB
{
user_id
=
optional
"id"
,
user_password
=
required
"password"
,
user_lastLogin
=
optional
"last_login"
,
user_isSuperUser
=
required
"is_superuser"
...
...
@@ -122,7 +121,7 @@ insertUsers us = mkCmd $ \c -> runInsert_ c insert
gargantextUser
::
Username
->
UserWrite
gargantextUser
u
=
User
(
Nothing
)
(
pgStrictText
"password"
)
gargantextUser
u
=
User
DB
(
Nothing
)
(
pgStrictText
"password"
)
(
Nothing
)
(
pgBool
True
)
(
pgStrictText
u
)
(
pgStrictText
"first_name"
)
(
pgStrictText
"last_name"
)
...
...
@@ -132,14 +131,13 @@ gargantextUser u = User (Nothing) (pgStrictText "password")
insertUsersDemo
::
Cmd
err
Int64
insertUsersDemo
=
insertUsers
$
map
(
\
u
->
gargantextUser
u
)
arbitraryUsername
------------------------------------------------------------------
queryUserTable
::
Query
UserRead
queryUserTable
=
queryTable
userTable
selectUsersLight
::
Query
UserRead
selectUsersLight
=
proc
()
->
do
row
@
(
User
i
_p
_ll
_is
_un
_fn
_ln
_m
_iff
_ive
_dj
)
<-
queryUserTable
-<
()
row
@
(
User
DB
i
_p
_ll
_is
_un
_fn
_ln
_m
_iff
_ive
_dj
)
<-
queryUserTable
-<
()
restrict
-<
i
.==
1
--returnA -< User i p ll is un fn ln m iff ive dj
returnA
-<
row
...
...
@@ -150,10 +148,10 @@ userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
userWith
f
t
xs
=
find
(
\
x
->
f
x
==
t
)
xs
-- | Select User with Username
userWithUsername
::
Text
->
[
User
]
->
Maybe
User
userWithUsername
::
Text
->
[
User
DB
]
->
Maybe
UserDB
userWithUsername
t
xs
=
userWith
user_username
t
xs
userWithId
::
Int
->
[
User
]
->
Maybe
User
userWithId
::
Int
->
[
User
DB
]
->
Maybe
UserDB
userWithId
t
xs
=
userWith
user_id
t
xs
userLightWithUsername
::
Text
->
[
UserLight
]
->
Maybe
UserLight
...
...
@@ -167,7 +165,7 @@ instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
queryRunnerColumnDefault
=
fieldQueryRunnerColumn
users
::
Cmd
err
[
User
]
users
::
Cmd
err
[
User
DB
]
users
=
runOpaQuery
queryUserTable
usersLight
::
Cmd
err
[
UserLight
]
...
...
@@ -177,3 +175,14 @@ getUser :: Username -> Cmd err (Maybe UserLight)
getUser
u
=
userLightWithUsername
u
<$>
usersLight
getUserId
::
HasNodeError
err
=>
User
->
Cmd
err
UserId
getUserId
(
UserDBId
uid
)
=
pure
uid
getUserId
(
UserName
u
)
=
do
muser
<-
getUser
u
case
muser
of
Just
user
->
pure
$
userLight_id
user
Nothing
->
nodeError
NoUserFound
src/Gargantext/Viz/Graph/API.hs
View file @
9a23e2d1
...
...
@@ -48,7 +48,8 @@ import Gargantext.Database.Config
import
Gargantext.Database.Metrics.NgramsByNode
(
getNodesByNgramsOnlyUser
)
import
Gargantext.Database.Schema.Ngrams
import
Gargantext.Database.Node.Select
import
Gargantext.Database.Schema.Node
(
getNodeWith
,
getNodeUser
,
defaultList
,
insertGraph
,
HasNodeError
)
import
Gargantext.Database.Schema.Node
(
getNodeWith
,
getNodeUser
,
defaultList
,
insertGraph
)
import
Gargantext.Database.Types.Errors
(
HasNodeError
)
import
Gargantext.Database.Types.Node
hiding
(
node_id
)
-- (GraphId, ListId, CorpusId, NodeId)
import
Gargantext.Database.Node.UpdateOpaleye
(
updateHyperdata
)
import
Gargantext.Database.Utils
(
Cmd
)
...
...
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