1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
{-|
Module : Gargantext.Database.Root
Description : Main requests to get root of users
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE Arrows #-}
module Gargantext.Database.Query.Tree.Root
where
import Control.Arrow (returnA)
import Gargantext.Core (HasDBid(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (CorpusName)
import Gargantext.Database.Action.Node ( mkNodeWithParent )
import Gargantext.Database.Action.User (getUserId, getUsername)
import Gargantext.Database.Admin.Config ( corpusMasterName, userMaster )
import Gargantext.Database.Admin.Types.Hyperdata.User ( HyperdataUser )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead, queryNodeTable)
import Gargantext.Prelude
import Opaleye (restrict, (.==), Select)
import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
getRootId :: (HasNodeError err) => User -> DBCmd err NodeId
getRootId u = do
maybeRoot <- head <$> getRoot u
case maybeRoot of
Nothing -> errorWith "[G.D.Q.T.R.getRootId] No root id"
Just r -> pure (_node_id r)
getRoot :: User -> DBCmd err [Node HyperdataUser]
getRoot = runOpaQuery . selectRoot
getOrMkRoot :: (HasNodeError err)
=> User
-> DBCmd err (UserId, RootId)
getOrMkRoot user = do
userId <- getUserId user
rootId' <- map _node_id <$> getRoot user
rootId'' <- case rootId' of
[] -> mkRoot user
n -> case length n >= 2 of
True -> nodeError $ NodeLookupFailed $ UserHasTooManyRoots userId n
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
pure (userId, rootId)
-- | Datatype for the `getOrMkRootWithCorpus`.
-- There are only 3 possibilities:
-- - User is userMaster and then there is no corpus name
-- - User is a normal user and then we pass corpus name
-- - User is a normal user and then we pass corpus ids
data MkCorpusUser =
MkCorpusUserMaster
| MkCorpusUserNormalCorpusName User CorpusName
| MkCorpusUserNormalCorpusIds User [CorpusId]
deriving (Eq, Show)
userFromMkCorpusUser :: MkCorpusUser -> User
userFromMkCorpusUser MkCorpusUserMaster = UserName userMaster
userFromMkCorpusUser (MkCorpusUserNormalCorpusIds u _cids) = u
userFromMkCorpusUser (MkCorpusUserNormalCorpusName u _cname) = u
getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
=> MkCorpusUser
-> Maybe a
-> DBCmd err (UserId, RootId, CorpusId)
getOrMkRootWithCorpus MkCorpusUserMaster c = do
(userId, rootId) <- getOrMkRoot (UserName userMaster)
corpusId'' <- do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
case corpusId'' of
[] -> mkCorpus corpusMasterName c rootId userId
cIds -> do
corpusId <- maybe (nodeError NoCorpusFound) pure (head cIds)
pure (userId, rootId, corpusId)
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusName user cName) c = do
(userId, rootId) <- getOrMkRoot user
mkCorpus cName c rootId userId
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusIds user []) c = do
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusName user "Default") c
getOrMkRootWithCorpus (MkCorpusUserNormalCorpusIds user cIds) _c = do
(userId, rootId) <- getOrMkRoot user
corpusId <- maybe (nodeError NoCorpusFound) pure (head cIds)
pure (userId, rootId, corpusId)
-- | Helper function for `getOrMkRootWithCorpus`.
mkCorpus :: (HasNodeError err, MkCorpus a)
=> CorpusName
-> Maybe a
-> RootId
-> UserId
-> DBCmd err (UserId, RootId, CorpusId)
mkCorpus cName c rootId userId = do
c' <- mk (Just cName) c rootId userId
_tId <- case head c' of
Nothing -> errorWith "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
Just c'' -> insertDefaultNode NodeTexts c'' userId
corpusId <- maybe (nodeError NoCorpusFound) pure (head c')
pure (userId, rootId, corpusId)
mkRoot :: HasNodeError err
=> User
-> DBCmd err [RootId]
mkRoot user = do
-- TODO
-- udb <- getUserDb user
-- let uid = user_id udb
uid <- getUserId user
-- TODO ? Which name for user Node ?
una <- getUsername user
case isPositive uid of
False -> nodeError $ NodeCreationFailed (UserHasNegativeId uid)
True -> do
rs <- mkNodeWithParent NodeUser Nothing uid una
_ <- case rs of
[r] -> do
_ <- insertNode NodeFolderPrivate Nothing Nothing r uid
_ <- insertNode NodeFolderShared Nothing Nothing r uid
_ <- insertNode NodeFolderPublic Nothing Nothing r uid
pure rs
_ -> pure rs
pure rs
selectRoot :: User -> Select NodeRead
selectRoot (UserName username) = proc () -> do
row <- queryNodeTable -< ()
users <- queryUserTable -< ()
restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< user_username users .== sqlStrictText username
restrict -< _node_user_id row .== user_id users
returnA -< row
selectRoot (UserDBId uid) = proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< _node_user_id row .== sqlInt4 (_UserId uid)
returnA -< row
selectRoot (RootId nid) =
proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_typename row .== sqlInt4 (toDBid NodeUser)
restrict -< _node_id row .== pgNodeId nid
returnA -< row