]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Query/Tree/Root.hs
[ngrams] add r_history %~ mempty to ngrams POST
[gargantext.git] / src / Gargantext / Database / Query / Tree / Root.hs
1 {-|
2 Module : Gargantext.Database.Root
3 Description : Main requests to get root of users
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9 -}
10
11 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE ConstraintKinds #-}
16 {-# LANGUAGE FunctionalDependencies #-}
17 {-# LANGUAGE TemplateHaskell #-}
18
19 module Gargantext.Database.Query.Tree.Root
20 where
21
22 import Data.Either (Either, fromLeft, fromRight)
23 import Control.Arrow (returnA)
24 import Gargantext.Core.Types.Main (CorpusName)
25 import Gargantext.Core.Types.Individu (User(..))
26 import Gargantext.Database.Admin.Config (nodeTypeId, userMaster)
27 import Gargantext.Database.Query.Table.Node.Error
28 import Gargantext.Database.Admin.Types.Node
29 import Gargantext.Database.Query.Table.Node
30 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
31 import Gargantext.Database.Action.Flow.Utils (getUserId)
32 import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
33 import Gargantext.Database.Schema.Node (queryNodeTable)
34 import Gargantext.Database.Action.Node
35 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
36 import Gargantext.Database.Admin.Types.Node (Node, NodeType(NodeUser), pgNodeId)
37 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
38 import Gargantext.Prelude
39 import Opaleye (restrict, (.==), Query)
40 import Opaleye.PGTypes (pgStrictText, pgInt4)
41
42
43 getRootId :: User -> Cmd err NodeId
44 getRootId u = do
45 maybeRoot <- head <$> getRoot u
46 case maybeRoot of
47 Nothing -> panic "no root id"
48 Just r -> pure (_node_id r)
49
50 getRoot :: User -> Cmd err [Node HyperdataUser]
51 getRoot = runOpaQuery . selectRoot
52
53
54 getOrMkRoot :: (HasNodeError err)
55 => User
56 -> Cmd err (UserId, RootId)
57 getOrMkRoot user = do
58 userId <- getUserId user
59
60 rootId' <- map _node_id <$> getRoot user
61
62 rootId'' <- case rootId' of
63 [] -> mkRoot user
64 n -> case length n >= 2 of
65 True -> nodeError ManyNodeUsers
66 False -> pure rootId'
67
68 rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
69 pure (userId, rootId)
70
71
72 getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
73 => User
74 -> Either CorpusName [CorpusId]
75 -> Maybe a
76 -> Cmd err (UserId, RootId, CorpusId)
77 getOrMk_RootWithCorpus user cName c = do
78 (userId, rootId) <- getOrMkRoot user
79 corpusId'' <- if user == UserName userMaster
80 then do
81 ns <- getCorporaWithParentId rootId
82 pure $ map _node_id ns
83 else
84 pure $ fromRight [] cName
85
86 corpusId' <- if corpusId'' /= []
87 then pure corpusId''
88 else do
89 c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
90 _tId <- case head c' of
91 Nothing -> pure [0]
92 Just c'' -> insertDefaultNode NodeTexts c'' userId
93 pure c'
94
95 corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
96 pure (userId, rootId, corpusId)
97
98
99
100
101
102
103 mkRoot :: HasNodeError err
104 => User
105 -> Cmd err [RootId]
106 mkRoot user = do
107
108 -- TODO
109 -- udb <- getUserDb user
110 -- let uid = user_id udb
111 uid <- getUserId user
112
113 -- TODO ? Which name for user Node ?
114 let una = "username"
115
116 case uid > 0 of
117 False -> nodeError NegativeId
118 True -> do
119 rs <- mkNodeWithParent NodeUser Nothing uid una
120 _ <- case rs of
121 [r] -> do
122 _ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
123 _ <- mkNodeWithParent NodeFolderShared (Just r) uid una
124 _ <- mkNodeWithParent NodeFolderPublic (Just r) uid una
125 pure rs
126 _ -> pure rs
127 pure rs
128
129 selectRoot :: User -> Query NodeRead
130 selectRoot (UserName username) = proc () -> do
131 row <- queryNodeTable -< ()
132 users <- queryUserTable -< ()
133 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
134 restrict -< user_username users .== (pgStrictText username)
135 restrict -< _node_userId row .== (user_id users)
136 returnA -< row
137
138 selectRoot (UserDBId uid) = proc () -> do
139 row <- queryNodeTable -< ()
140 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
141 restrict -< _node_userId row .== (pgInt4 uid)
142 returnA -< row
143
144 selectRoot (RootId nid) =
145 proc () -> do
146 row <- queryNodeTable -< ()
147 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
148 restrict -< _node_id row .== (pgNodeId nid)
149 returnA -< row
150 selectRoot UserPublic = panic "No root for Public"