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
{-|
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
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (CorpusName)
import Gargantext.Database.Action.Node
import Gargantext.Database.Action.User (getUserId, getUsername)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Hyperdata (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)
import Gargantext.Database.Schema.Node (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)
getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> Maybe a
-> DBCmd err (UserId, RootId, CorpusId)
getOrMk_RootWithCorpus user cName c = do
(userId, rootId) <- getOrMkRoot user
corpusId'' <- if user == UserName userMaster
then do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
else
pure $ fromRight [] cName
corpusId' <- if corpusId'' /= []
then pure corpusId''
else do
c' <- mk (Just $ fromLeft "Default" 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
pure c'
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
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