]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Node.hs
[FLOW][DB][LIST] creating subflow for list
[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 ConstraintKinds #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE FlexibleInstances #-}
19 {-# LANGUAGE FunctionalDependencies #-}
20 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
21 {-# LANGUAGE OverloadedStrings #-}
22 {-# LANGUAGE MultiParamTypeClasses #-}
23 {-# LANGUAGE NoImplicitPrelude #-}
24 {-# LANGUAGE TemplateHaskell #-}
25
26 module Gargantext.Database.Node where
27
28 import Data.Text (pack)
29 import GHC.Int (Int64)
30 import Control.Lens (set)
31 import Data.Maybe
32 import Data.Time (UTCTime)
33 import Database.PostgreSQL.Simple.FromField ( Conversion
34 , ResultError(ConversionFailed)
35 , FromField
36 , fromField
37 , returnError
38 )
39 import Prelude hiding (null, id, map, sum)
40
41 import Gargantext.Core (Lang(..))
42 import Gargantext.Core.Types
43 import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
44 import Gargantext.Database.Queries
45 import Gargantext.Database.Config (nodeTypeId)
46 import Gargantext.Prelude hiding (sum)
47
48 import Database.PostgreSQL.Simple.Internal (Field)
49 import Control.Applicative (Applicative)
50 import Control.Arrow (returnA)
51 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
52 import Control.Monad.IO.Class
53 import Control.Monad.Reader
54 import Data.Aeson
55 import Data.Maybe (Maybe, fromMaybe)
56 import Data.Text (Text)
57 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
58 import Data.Typeable (Typeable)
59
60 import qualified Data.ByteString as DB
61 import qualified Data.ByteString.Lazy as DBL
62 import Data.ByteString (ByteString)
63
64 import Database.PostgreSQL.Simple (Connection)
65 import Opaleye hiding (FromField)
66 import Opaleye.Internal.QueryArr (Query)
67 import qualified Data.Profunctor.Product as PP
68
69 ------------------------------------------------------------------------
70 {- | Reader Monad reinvented here:
71
72 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
73
74 instance Monad Cmd where
75 return a = Cmd $ \_ -> return a
76
77 m >>= f = Cmd $ \c -> do
78 a <- unCmd m c
79 unCmd (f a) c
80 -}
81 newtype Cmd a = Cmd (ReaderT Connection IO a)
82 deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
83
84 runCmd :: Connection -> Cmd a -> IO a
85 runCmd c (Cmd f) = runReaderT f c
86
87 mkCmd :: (Connection -> IO a) -> Cmd a
88 mkCmd = Cmd . ReaderT
89
90 ------------------------------------------------------------------------
91 type CorpusId = Int
92 type AnnuaireId = Int
93
94 type DocId = Int
95 type UserId = Int
96 type TypeId = Int
97 ------------------------------------------------------------------------
98 instance FromField HyperdataAny where
99 fromField = fromField'
100
101 instance FromField HyperdataCorpus where
102 fromField = fromField'
103
104 instance FromField HyperdataDocument where
105 fromField = fromField'
106
107 instance FromField HyperdataDocumentV3 where
108 fromField = fromField'
109
110 instance FromField HyperdataUser where
111 fromField = fromField'
112
113 instance FromField HyperdataAnnuaire where
114 fromField = fromField'
115 ------------------------------------------------------------------------
116 instance QueryRunnerColumnDefault PGJsonb HyperdataAny where
117 queryRunnerColumnDefault = fieldQueryRunnerColumn
118
119 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
120 queryRunnerColumnDefault = fieldQueryRunnerColumn
121
122 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
123 queryRunnerColumnDefault = fieldQueryRunnerColumn
124
125 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
126 queryRunnerColumnDefault = fieldQueryRunnerColumn
127
128 instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
129 queryRunnerColumnDefault = fieldQueryRunnerColumn
130
131 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire where
132 queryRunnerColumnDefault = fieldQueryRunnerColumn
133 ------------------------------------------------------------------------
134
135 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
136 fromField' field mb = do
137 v <- fromField field mb
138 valueToHyperdata v
139 where
140 valueToHyperdata v = case fromJSON v of
141 Success a -> pure a
142 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
143
144
145 $(makeAdaptorAndInstance "pNode" ''NodePoly)
146 $(makeLensesWith abbreviatedFields ''NodePoly)
147
148
149 nodeTable :: Table NodeWrite NodeRead
150 nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
151 , _node_typename = required "typename"
152 , _node_userId = required "user_id"
153 , _node_parentId = required "parent_id"
154 , _node_name = required "name"
155 , _node_date = optional "date"
156 , _node_hyperdata = required "hyperdata"
157 -- , node_titleAbstract = optional "title_abstract"
158 }
159 )
160
161
162 nodeTable' :: Table (Maybe (Column PGInt4)
163 , Column PGInt4
164 , Column PGInt4
165 ,Maybe (Column PGInt4)
166 , Column PGText
167 ,Maybe (Column PGTimestamptz)
168 , Column PGJsonb
169 )
170 ((Column PGInt4)
171 , Column PGInt4
172 , Column PGInt4
173 , Column PGInt4
174 , Column PGText
175 ,(Column PGTimestamptz)
176 , Column PGJsonb
177 )
178
179 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
180 , required "typename"
181 , required "user_id"
182 , optional "parent_id"
183 , required "name"
184 , optional "date"
185 , required "hyperdata"
186 )
187 )
188
189
190 queryNodeTable :: Query NodeRead
191 queryNodeTable = queryTable nodeTable
192
193 selectNode :: Column PGInt4 -> Query NodeRead
194 selectNode id = proc () -> do
195 row <- queryNodeTable -< ()
196 restrict -< _node_id row .== id
197 returnA -< row
198
199 runGetNodes :: Query NodeRead -> Cmd [NodeAny]
200 runGetNodes q = mkCmd $ \conn -> runQuery conn q
201
202 ------------------------------------------------------------------------
203 selectRootUser :: UserId -> Query NodeRead
204 selectRootUser userId = proc () -> do
205 row <- queryNodeTable -< ()
206 restrict -< _node_userId row .== (pgInt4 userId)
207 restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
208 returnA -< row
209
210 getRoot :: UserId -> Cmd [Node HyperdataUser]
211 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
212 ------------------------------------------------------------------------
213
214 -- | order by publication date
215 -- Favorites (Bool), node_ngrams
216 selectNodesWith :: ParentId -> Maybe NodeType
217 -> Maybe Offset -> Maybe Limit -> Query NodeRead
218 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
219 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
220 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
221
222 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
223 selectNodesWith' parentId maybeNodeType = proc () -> do
224 node <- (proc () -> do
225 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
226 restrict -< parentId' .== (toNullable $ pgInt4 parentId)
227
228 let typeId' = maybe 0 nodeTypeId maybeNodeType
229
230 restrict -< if typeId' > 0
231 then typeId .== (pgInt4 (typeId' :: Int))
232 else (pgBool True)
233 returnA -< row ) -< ()
234 returnA -< node
235
236
237 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
238
239
240 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
241 -- deleteNode :: Int -> Cmd' Int
242
243 deleteNode :: Int -> Cmd Int
244 deleteNode n = mkCmd $ \conn ->
245 fromIntegral <$> runDelete conn nodeTable
246 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
247
248 deleteNodes :: [Int] -> Cmd Int
249 deleteNodes ns = mkCmd $ \conn ->
250 fromIntegral <$> runDelete conn nodeTable
251 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
252
253
254 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
255 -> Maybe Offset -> Maybe Limit -> IO [Node a]
256 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
257 runQuery conn $ selectNodesWith
258 parentId nodeType maybeOffset maybeLimit
259
260
261 -- NP check type
262 getNodesWithParentId :: Int
263 -> Maybe Text -> Connection -> IO [NodeAny]
264 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
265
266 getNodesWithParentId' :: Int
267 -> Maybe Text -> Connection -> IO [NodeAny]
268 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
269
270
271 ------------------------------------------------------------------------
272 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
273 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
274
275 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
276 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
277
278 ------------------------------------------------------------------------
279
280
281 selectNodesWithParentID :: Int -> Query NodeRead
282 selectNodesWithParentID n = proc () -> do
283 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
284 restrict -< if n > 0
285 then
286 parent_id .== (toNullable $ pgInt4 n)
287 else
288 isNull parent_id
289 returnA -< row
290
291
292 selectNodesWithType :: Column PGInt4 -> Query NodeRead
293 selectNodesWithType type_id = proc () -> do
294 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
295 restrict -< tn .== type_id
296 returnA -< row
297
298 type JSONB = QueryRunnerColumnDefault PGJsonb
299
300 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
301 getNode conn id _ = do
302 fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
303
304
305 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
306 getNodesWithType conn type_id = do
307 runQuery conn $ selectNodesWithType type_id
308
309
310 ------------------------------------------------------------------------
311 -- WIP
312 -- TODO Classe HasDefault where
313 -- default NodeType = Hyperdata
314 ------------------------------------------------------------------------
315 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
316 ------------------------------------------------------------------------
317 defaultUser :: HyperdataUser
318 defaultUser = HyperdataUser (Just $ (pack . show) EN)
319
320 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
321 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
322 where
323 name = maybe "User" identity maybeName
324 user = maybe defaultUser identity maybeHyperdata
325 ------------------------------------------------------------------------
326 defaultFolder :: HyperdataFolder
327 defaultFolder = HyperdataFolder (Just "Markdown Description")
328
329 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
330 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
331 where
332 name = maybe "Folder" identity maybeName
333 folder = maybe defaultFolder identity maybeFolder
334 ------------------------------------------------------------------------
335 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
336 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
337 where
338 name = maybe "Corpus" identity maybeName
339 corpus = maybe defaultCorpus identity maybeCorpus
340 --------------------------
341 defaultDocument :: HyperdataDocument
342 defaultDocument = hyperdataDocument
343
344 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
345 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
346 where
347 name = maybe "Document" identity maybeName
348 doc = maybe defaultDocument identity maybeDocument
349 ------------------------------------------------------------------------
350 defaultAnnuaire :: HyperdataAnnuaire
351 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
352
353 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
354 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
355 where
356 name = maybe "Annuaire" identity maybeName
357 annuaire = maybe defaultAnnuaire identity maybeAnnuaire
358 --------------------------
359 defaultContact :: HyperdataContact
360 defaultContact = HyperdataContact (Just "Name") (Just "email@here")
361
362 nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
363 nodeContactW maybeName maybeContact aId = node NodeContact name contact (Just aId)
364 where
365 name = maybe "Contact" identity maybeName
366 contact = maybe defaultContact identity maybeContact
367 ------------------------------------------------------------------------
368 defaultList :: HyperdataList
369 defaultList = HyperdataList (Just "Preferences")
370
371 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite'
372 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
373 where
374 name = maybe "Listes" identity maybeName
375 list = maybe defaultList identity maybeList
376
377 ------------------------------------------------------------------------
378 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
379 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
380 where
381 typeId = nodeTypeId nodeType
382 byteData = DB.pack . DBL.unpack $ encode hyperData
383
384 -------------------------------
385 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
386 NodePoly (maybe2 Int) Int Int (maybe1 Int)
387 Text (maybe3 UTCTime) ByteString
388 -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
389 , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
390 node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
391 ,(pgInt4 tn)
392 ,(pgInt4 ud)
393 ,(pgInt4 <$> pid)
394 ,(pgStrictText nm)
395 ,(pgUTCTime <$> dt)
396 ,(pgStrictJSONB hp)
397 )
398 ------------------------------------------------------------------------
399 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
400 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
401
402 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
403 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
404
405 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
406 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
407 -------------------------
408 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
409 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
410
411 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
412 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
413 ------------------------------------------------------------------------
414 -- TODO Hierachy of Nodes
415 -- post and get same types Node' and update if changes
416
417 {- TODO semantic to achieve
418 post c uid pid [ Node' NodeCorpus "name" "{}" []
419 , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
420 , Node' NodeDocument "title" "jsonData" []
421 ]
422 ]
423 ]
424 -}
425 ------------------------------------------------------------------------
426
427 -- TODO
428 -- currently this function remove the child relation
429 -- needs a Temporary type between Node' and NodeWriteT
430 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
431 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
432 , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
433 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
434
435
436 data Node' = Node' { _n_type :: NodeType
437 , _n_name :: Text
438 , _n_data :: Value
439 , _n_children :: [Node']
440 } deriving (Show)
441
442
443 type NodeWriteT = ( Maybe (Column PGInt4)
444 , Column PGInt4
445 , Column PGInt4
446 , Maybe (Column PGInt4)
447 , Column PGText
448 , Maybe (Column PGTimestamptz)
449 , Column PGJsonb
450 )
451
452
453 mkNode' :: [NodeWriteT] -> Cmd Int64
454 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
455
456 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
457 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
458
459
460 ------------------------------------------------------------------------
461
462 data NewNode = NewNode { _newNodeId :: Int
463 , _newNodeChildren :: [Int] }
464
465 -- | postNode
466 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
467 postNode uid pid (Node' nt txt v []) = do
468 pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
469 case pids of
470 [pid] -> pure $ NewNode pid []
471 _ -> panic "postNode: only one pid expected"
472
473 postNode uid pid (Node' NodeCorpus txt v ns) = do
474 NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
475 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
476 pure $ NewNode pid' pids
477
478 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
479 NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
480 pids <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
481 pure $ NewNode pid' pids
482 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
483
484
485 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
486 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
487 childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
488 childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
489
490
491 -- TODO: remove hardcoded userId (with Reader)
492 -- TODO: user Reader in the API and adapt this function
493 userId :: Int
494 userId = 1
495
496 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
497 mk c nt pId name = mk' c nt userId pId name
498
499 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
500 mk' c nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
501 where
502 hd = HyperdataUser . Just . pack $ show EN
503
504 type Name = Text
505
506 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
507 mk'' NodeUser Nothing uId name = mkCmd $ \c -> mk' c NodeUser uId Nothing name
508 mk'' NodeUser _ _ _ = panic "NodeUser do not have any parent"
509 mk'' _ Nothing _ _ = panic "NodeType does have a parent"
510 mk'' nt pId uId name = mkCmd $ \c -> mk' c nt uId pId name
511
512 mkRoot :: UserId -> Cmd [Int]
513 mkRoot uId = case uId > 0 of
514 False -> panic "UserId <= 0"
515 True -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
516
517 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
518 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
519
520 mkList :: ParentId -> UserId -> Cmd [Int]
521 mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
522