]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Node.hs
[DOC] adding a file for examples, text ngrams extraction and some metrics (begin).
[gargantext.git] / src / Gargantext / Database / Node.hs
1 {-|
2 Module : Gargantext.Database.Node
3 Description : Main requests of Node to the database
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 DeriveGeneric #-}
16 {-# LANGUAGE FlexibleInstances #-}
17 {-# LANGUAGE FunctionalDependencies #-}
18 {-# LANGUAGE MultiParamTypeClasses #-}
19 {-# LANGUAGE NoImplicitPrelude #-}
20 {-# LANGUAGE TemplateHaskell #-}
21
22 module Gargantext.Database.Node where
23
24
25 import GHC.Int (Int64)
26 import Data.Maybe
27 import Data.Time (UTCTime)
28 import Database.PostgreSQL.Simple.FromField ( Conversion
29 , ResultError(ConversionFailed)
30 , FromField
31 , fromField
32 , returnError
33 )
34 import Prelude hiding (null, id, map, sum)
35
36 import Gargantext.Core.Types
37 import Gargantext.Core.Types.Node (NodeType)
38 import Gargantext.Database.Queries
39 import Gargantext.Prelude hiding (sum)
40
41
42 import Database.PostgreSQL.Simple.Internal (Field)
43 import Control.Arrow (returnA)
44 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
45 import Data.Aeson
46 import Data.Maybe (Maybe, fromMaybe)
47 import Data.Text (Text, pack)
48 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
49 import Data.Typeable (Typeable)
50
51 import qualified Data.ByteString as DB
52 import qualified Data.ByteString.Lazy as DBL
53 import Data.ByteString (ByteString)
54
55 import Database.PostgreSQL.Simple (Connection)
56 import Opaleye hiding (FromField)
57 import Opaleye.Internal.QueryArr (Query)
58 import qualified Data.Profunctor.Product as PP
59 -- | Types for Node Database Management
60 data PGTSVector
61
62
63 instance FromField HyperdataCorpus where
64 fromField = fromField'
65
66 instance FromField HyperdataDocument where
67 fromField = fromField'
68
69 instance FromField HyperdataDocumentV3 where
70 fromField = fromField'
71
72 instance FromField HyperdataProject where
73 fromField = fromField'
74
75 instance FromField HyperdataUser where
76 fromField = fromField'
77
78
79 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
80 queryRunnerColumnDefault = fieldQueryRunnerColumn
81 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
82 queryRunnerColumnDefault = fieldQueryRunnerColumn
83
84 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
85 queryRunnerColumnDefault = fieldQueryRunnerColumn
86
87 instance QueryRunnerColumnDefault PGJsonb HyperdataProject where
88 queryRunnerColumnDefault = fieldQueryRunnerColumn
89
90 instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
91 queryRunnerColumnDefault = fieldQueryRunnerColumn
92
93
94
95 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
96 fromField' field mb = do
97 v <- fromField field mb
98 valueToHyperdata v
99 where
100 valueToHyperdata v = case fromJSON v of
101 Success a -> pure a
102 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
103
104
105 $(makeAdaptorAndInstance "pNode" ''NodePoly)
106 $(makeLensesWith abbreviatedFields ''NodePoly)
107
108
109 nodeTable :: Table NodeWrite NodeRead
110 nodeTable = Table "nodes" (pNode Node { node_id = optional "id"
111 , node_typename = required "typename"
112 , node_userId = required "user_id"
113 , node_parentId = required "parent_id"
114 , node_name = required "name"
115 , node_date = optional "date"
116 , node_hyperdata = required "hyperdata"
117 -- , node_titleAbstract = optional "title_abstract"
118 }
119 )
120
121
122 nodeTable' :: Table (Maybe (Column PGInt4)
123 , Column PGInt4
124 , Column PGInt4
125 , Column PGInt4
126 , Column PGText
127 ,Maybe (Column PGTimestamptz)
128 , Column PGJsonb
129 )
130 ((Column PGInt4)
131 , Column PGInt4
132 , Column PGInt4
133 , Column PGInt4
134 , Column PGText
135 ,(Column PGTimestamptz)
136 , Column PGJsonb
137 )
138
139 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
140 , required "typename"
141 , required "user_id"
142 , required "parent_id"
143 , required "name"
144 , optional "date"
145 , required "hyperdata"
146 )
147 )
148
149
150 queryNodeTable :: Query NodeRead
151 queryNodeTable = queryTable nodeTable
152
153
154 selectNode :: Column PGInt4 -> Query NodeRead
155 selectNode id = proc () -> do
156 row <- queryNodeTable -< ()
157 restrict -< node_id row .== id
158 returnA -< row
159
160 runGetNodes :: Connection -> Query NodeRead -> IO [Node Value]
161 runGetNodes = runQuery
162
163 -- | order by publication date
164 -- Favorites (Bool), node_ngrams
165 selectNodesWith :: ParentId -> Maybe NodeType
166 -> Maybe Offset -> Maybe Limit -> Query NodeRead
167 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
168 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
169 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc node_id) $ selectNodesWith' parentId maybeNodeType
170
171 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
172 selectNodesWith' parentId maybeNodeType = proc () -> do
173 node <- (proc () -> do
174 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
175 restrict -< parentId' .== (toNullable $ pgInt4 parentId)
176
177 let typeId' = maybe 0 nodeTypeId maybeNodeType
178
179 restrict -< if typeId' > 0
180 then typeId .== (pgInt4 (typeId' :: Int))
181 else (pgBool True)
182 returnA -< row ) -< ()
183 returnA -< node
184
185
186
187 deleteNode :: Connection -> Int -> IO Int
188 deleteNode conn n = fromIntegral <$> runDelete conn nodeTable
189 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
190
191 deleteNodes :: Connection -> [Int] -> IO Int
192 deleteNodes conn ns = fromIntegral <$> runDelete conn nodeTable
193 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
194
195
196 getNodesWith :: Connection -> Int -> Maybe NodeType
197 -> Maybe Offset -> Maybe Limit -> IO [Node Value]
198 getNodesWith conn parentId nodeType maybeOffset maybeLimit =
199 runQuery conn $ selectNodesWith
200 parentId nodeType maybeOffset maybeLimit
201
202
203 -- NP check type
204 getNodesWithParentId :: Connection -> Int
205 -> Maybe Text -> IO [Node Value]
206 getNodesWithParentId conn n _ = runQuery conn $ selectNodesWithParentID n
207
208 getNodesWithParentId' :: Connection -> Int
209 -> Maybe Text -> IO [Node Value]
210 getNodesWithParentId' conn n _ = runQuery conn $ selectNodesWithParentID n
211
212
213
214 ------------------------------------------------------------------------
215 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
216 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
217
218 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
219 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just Document)
220
221 ------------------------------------------------------------------------
222
223
224 selectNodesWithParentID :: Int -> Query NodeRead
225 selectNodesWithParentID n = proc () -> do
226 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
227 restrict -< if n > 0
228 then
229 parent_id .== (toNullable $ pgInt4 n)
230 else
231 isNull parent_id
232 returnA -< row
233
234
235 selectNodesWithType :: Column PGInt4 -> Query NodeRead
236 selectNodesWithType type_id = proc () -> do
237 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
238 restrict -< tn .== type_id
239 returnA -< row
240
241
242 getNode :: Connection -> Int -> IO (Node Value)
243 getNode conn id = do
244 fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
245
246
247 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
248 getNodesWithType conn type_id = do
249 runQuery conn $ selectNodesWithType type_id
250
251 type UserId = NodeId
252 type TypeId = Int
253
254
255 ------------------------------------------------------------------------
256 -- Quick and dirty
257 ------------------------------------------------------------------------
258 type NodeWrite' = NodePoly (Maybe Int) Int Int (ParentId) Text (Maybe UTCTime) ByteString
259
260 --node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
261 node :: UserId -> ParentId -> NodeType -> Text -> Value -> NodeWrite'
262 node userId parentId nodeType name nodeData = Node Nothing typeId userId parentId name Nothing byteData
263 where
264 typeId = nodeTypeId nodeType
265 byteData = DB.pack $ DBL.unpack $ encode nodeData
266
267
268
269 node2write :: (Functor f2, Functor f1) =>
270 Int
271 -> NodePoly (f1 Int) Int Int parentId Text (f2 UTCTime) ByteString
272 -> (f1 (Column PGInt4), Column PGInt4, Column PGInt4,
273 Column PGInt4, Column PGText, f2 (Column PGTimestamptz),
274 Column PGJsonb)
275 node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4 <$> id)
276 ,(pgInt4 tn)
277 ,(pgInt4 ud)
278 ,(pgInt4 pid)
279 ,(pgStrictText nm)
280 ,(pgUTCTime <$> dt)
281 ,(pgStrictJSONB hp)
282 )
283
284
285 mkNode :: Connection -> ParentId -> [NodeWrite'] -> IO Int64
286 mkNode conn pid ns = runInsertMany conn nodeTable' $ map (node2write pid) ns
287
288 mkNodeR :: Connection -> ParentId -> [NodeWrite'] -> IO [Int]
289 mkNodeR conn pid ns = runInsertManyReturning conn nodeTable' (map (node2write pid) ns) (\(i,_,_,_,_,_,_) -> i)
290
291
292 ------------------------------------------------------------------------
293 -- TODO Hierachy of Nodes
294 -- post and get same types Node' and update if changes
295
296 {- TODO semantic to achieve
297 post c uid pid [ Node' Corpus "name" "{}" []
298 , Node' Folder "name" "{}" [Node' Corpus "test 2" "" [ Node' Document "title" "metaData" []
299 , Node' Document "title" "jsonData" []
300 ]
301 ]
302 ]
303 -}
304 ------------------------------------------------------------------------
305
306 -- TODO
307 -- currently this function remove the child relation
308 -- needs a Temporary type between Node' and NodeWriteT
309 node2table :: UserId -> ParentId -> Node' -> [NodeWriteT]
310 node2table uid pid (Node' nt txt v []) = [( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
311 , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)]
312 node2table _ _ (Node' _ _ _ _) = panic $ pack "node2table: should not happen, Tree insert not implemented yet"
313
314
315 data Node' = Node' { _n_type :: NodeType
316 , _n_name :: Text
317 , _n_data :: Value
318 , _n_children :: [Node']
319 } deriving (Show)
320
321
322 type NodeWriteT = ( Maybe (Column PGInt4)
323 , Column PGInt4, Column PGInt4
324 , Column PGInt4, Column PGText
325 , Maybe (Column PGTimestamptz)
326 , Column PGJsonb
327 )
328
329
330 mkNode' :: Connection -> [NodeWriteT] -> IO Int64
331 mkNode' conn ns = runInsertMany conn nodeTable' ns
332
333 mkNodeR' :: Connection -> [NodeWriteT] -> IO [Int]
334 mkNodeR' conn ns = runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
335
336 -- | postNode
337 postNode :: Connection -> UserId -> ParentId -> Node' -> IO [Int]
338 postNode c uid pid (Node' nt txt v []) = mkNodeR' c (node2table uid pid (Node' nt txt v []))
339
340 postNode c uid pid (Node' NodeCorpus txt v ns) = do
341 [pid'] <- postNode c uid pid (Node' NodeCorpus txt v [])
342 pids <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
343 pure (pids)
344
345 postNode c uid pid (Node' Annuaire txt v ns) = do
346 [pid'] <- postNode c uid pid (Node' Annuaire txt v [])
347 pids <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
348 pure (pids)
349 postNode _ _ _ (Node' _ _ _ _) = panic $ pack "postNode for this type not implemented yet"
350
351
352 childWith :: UserId -> ParentId -> Node' -> [NodeWriteT]
353 childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
354 childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
355 childWith _ _ (Node' _ _ _ _) = panic $ pack "This NodeType can not be a child"
356