]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Schema/Node.hs
Merge branch 'dev-phylo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext...
[gargantext.git] / src / Gargantext / Database / Schema / Node.hs
1 {-|
2 Module : Gargantext.Database.Schema.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 OverloadedStrings #-}
21 {-# LANGUAGE MultiParamTypeClasses #-}
22 {-# LANGUAGE NoImplicitPrelude #-}
23 {-# LANGUAGE RankNTypes #-}
24 {-# LANGUAGE TemplateHaskell #-}
25
26 module Gargantext.Database.Schema.Node where
27
28 import Control.Arrow (returnA)
29 import Control.Lens (Prism', set, view, (#), (^?))
30 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
31 import Control.Monad.Error.Class (MonadError(..))
32 import Data.Aeson
33 import Data.Maybe (Maybe(..), fromMaybe)
34 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
35 import Data.Text (Text, pack)
36 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
37 import GHC.Int (Int64)
38 import Gargantext.Core (Lang(..))
39 import Gargantext.Core.Types
40 import Gargantext.Core.Types.Individu (Username)
41 import Gargantext.Database.Config (nodeTypeId)
42 import Gargantext.Database.Queries.Filter (limit', offset')
43 import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
44 import Gargantext.Database.Utils
45 import Gargantext.Prelude hiding (sum, head)
46 import Opaleye hiding (FromField)
47 import Opaleye.Internal.QueryArr (Query)
48 import Prelude hiding (null, id, map, sum)
49
50 ------------------------------------------------------------------------
51
52 data NodeError = NoListFound
53 | NoRootFound
54 | NoCorpusFound
55 | NoUserFound
56 | MkNode
57 | UserNoParent
58 | HasParent
59 | ManyParents
60 | NegativeId
61 | NotImplYet
62 | ManyNodeUsers
63 deriving (Show)
64
65 class HasNodeError e where
66 _NodeError :: Prism' e NodeError
67
68 nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
69 nodeError ne = throwError $ _NodeError # ne
70
71 catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
72 catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
73
74 ------------------------------------------------------------------------
75 instance FromField HyperdataAny where
76 fromField = fromField'
77
78 instance FromField HyperdataCorpus
79 where
80 fromField = fromField'
81
82 instance FromField HyperdataDocument
83 where
84 fromField = fromField'
85
86 instance FromField HyperdataDocumentV3
87 where
88 fromField = fromField'
89
90 instance FromField HyperdataUser
91 where
92 fromField = fromField'
93
94 instance FromField HyperdataList
95 where
96 fromField = fromField'
97
98 instance FromField HyperdataListModel
99 where
100 fromField = fromField'
101
102 instance FromField HyperdataGraph
103 where
104 fromField = fromField'
105
106 instance FromField HyperdataAnnuaire
107 where
108 fromField = fromField'
109
110 instance FromField (NodeId, Text)
111 where
112 fromField = fromField'
113 ------------------------------------------------------------------------
114 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
115 where
116 queryRunnerColumnDefault = fieldQueryRunnerColumn
117
118 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
119 where
120 queryRunnerColumnDefault = fieldQueryRunnerColumn
121
122 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
123 where
124 queryRunnerColumnDefault = fieldQueryRunnerColumn
125
126 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
127 where
128 queryRunnerColumnDefault = fieldQueryRunnerColumn
129
130 instance QueryRunnerColumnDefault PGJsonb HyperdataUser
131 where
132 queryRunnerColumnDefault = fieldQueryRunnerColumn
133
134 instance QueryRunnerColumnDefault PGJsonb HyperdataList
135 where
136 queryRunnerColumnDefault = fieldQueryRunnerColumn
137
138 instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
139 where
140 queryRunnerColumnDefault = fieldQueryRunnerColumn
141
142 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
143 where
144 queryRunnerColumnDefault = fieldQueryRunnerColumn
145
146 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
147 where
148 queryRunnerColumnDefault = fieldQueryRunnerColumn
149
150 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
151 where
152 queryRunnerColumnDefault = fieldQueryRunnerColumn
153
154 instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
155 where
156 queryRunnerColumnDefault = fieldQueryRunnerColumn
157
158 instance QueryRunnerColumnDefault PGInt4 NodeId
159 where
160 queryRunnerColumnDefault = fieldQueryRunnerColumn
161
162 instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
163 where
164 queryRunnerColumnDefault = fieldQueryRunnerColumn
165
166
167 ------------------------------------------------------------------------
168 -- WIP
169 -- TODO Classe HasDefault where
170 -- default NodeType = Hyperdata
171 ------------------------------------------------------------------------
172 $(makeAdaptorAndInstance "pNode" ''NodePoly)
173 $(makeLensesWith abbreviatedFields ''NodePoly)
174
175 $(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
176 $(makeLensesWith abbreviatedFields ''NodePolySearch)
177
178 type NodeWrite = NodePoly (Maybe (Column PGInt4) )
179 (Column PGInt4)
180 (Column PGInt4)
181 (Maybe (Column PGInt4) )
182 (Column PGText)
183 (Maybe (Column PGTimestamptz))
184 (Column PGJsonb)
185
186 type NodeRead = NodePoly (Column PGInt4 )
187 (Column PGInt4 )
188 (Column PGInt4 )
189 (Column PGInt4 )
190 (Column PGText )
191 (Column PGTimestamptz )
192 (Column PGJsonb )
193
194 type NodeReadNull = NodePoly (Column (Nullable PGInt4))
195 (Column (Nullable PGInt4))
196 (Column (Nullable PGInt4))
197 (Column (Nullable PGInt4))
198 (Column (Nullable PGText))
199 (Column (Nullable PGTimestamptz))
200 (Column (Nullable PGJsonb))
201
202 nodeTable :: Table NodeWrite NodeRead
203 nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
204 , _node_typename = required "typename"
205 , _node_userId = required "user_id"
206
207 , _node_parentId = optional "parent_id"
208 , _node_name = required "name"
209 , _node_date = optional "date"
210
211 , _node_hyperdata = required "hyperdata"
212 }
213 )
214
215 queryNodeTable :: Query NodeRead
216 queryNodeTable = queryTable nodeTable
217
218 ------------------------------------------------------------------------
219 -- | Node(Read|Write)Search is slower than Node(Write|Read) use it
220 -- for full text search only
221 type NodeSearchWrite =
222 NodePolySearch
223 (Maybe (Column PGInt4) )
224 (Column PGInt4 )
225 (Column PGInt4 )
226 (Column (Nullable PGInt4) )
227 (Column PGText )
228 (Maybe (Column PGTimestamptz))
229 (Column PGJsonb )
230 (Maybe (Column PGTSVector) )
231
232 type NodeSearchRead =
233 NodePolySearch
234 (Column PGInt4 )
235 (Column PGInt4 )
236 (Column PGInt4 )
237 (Column (Nullable PGInt4 ))
238 (Column PGText )
239 (Column PGTimestamptz )
240 (Column PGJsonb )
241 (Column PGTSVector )
242
243 type NodeSearchReadNull =
244 NodePolySearch
245 (Column (Nullable PGInt4) )
246 (Column (Nullable PGInt4) )
247 (Column (Nullable PGInt4) )
248 (Column (Nullable PGInt4) )
249 (Column (Nullable PGText) )
250 (Column (Nullable PGTimestamptz))
251 (Column (Nullable PGJsonb) )
252 (Column (Nullable PGTSVector) )
253
254 --{-
255 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
256 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optional "id"
257 , _ns_typename = required "typename"
258 , _ns_userId = required "user_id"
259
260 , _ns_parentId = required "parent_id"
261 , _ns_name = required "name"
262 , _ns_date = optional "date"
263
264 , _ns_hyperdata = required "hyperdata"
265 , _ns_search = optional "search"
266 }
267 )
268 --}
269
270 queryNodeSearchTable :: Query NodeSearchRead
271 queryNodeSearchTable = queryTable nodeTableSearch
272
273 selectNode :: Column PGInt4 -> Query NodeRead
274 selectNode id = proc () -> do
275 row <- queryNodeTable -< ()
276 restrict -< _node_id row .== id
277 returnA -< row
278
279 runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
280 runGetNodes = runOpaQuery
281
282 ------------------------------------------------------------------------
283 ------------------------------------------------------------------------
284
285 -- | order by publication date
286 -- Favorites (Bool), node_ngrams
287 selectNodesWith :: ParentId -> Maybe NodeType
288 -> Maybe Offset -> Maybe Limit -> Query NodeRead
289 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
290 --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
291 limit' maybeLimit $ offset' maybeOffset
292 $ orderBy (asc _node_id)
293 $ selectNodesWith' parentId maybeNodeType
294
295 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
296 selectNodesWith' parentId maybeNodeType = proc () -> do
297 node <- (proc () -> do
298 row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
299 restrict -< parentId' .== (pgNodeId parentId)
300
301 let typeId' = maybe 0 nodeTypeId maybeNodeType
302
303 restrict -< if typeId' > 0
304 then typeId .== (pgInt4 (typeId' :: Int))
305 else (pgBool True)
306 returnA -< row ) -< ()
307 returnA -< node
308
309
310 deleteNode :: NodeId -> Cmd err Int
311 deleteNode n = mkCmd $ \conn ->
312 fromIntegral <$> runDelete conn nodeTable
313 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
314
315 deleteNodes :: [NodeId] -> Cmd err Int
316 deleteNodes ns = mkCmd $ \conn ->
317 fromIntegral <$> runDelete conn nodeTable
318 (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
319
320 -- TODO: NodeType should match with `a'
321 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
322 -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
323 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
324 runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
325
326 -- TODO: Why is the second parameter ignored?
327 -- TODO: Why not use getNodesWith?
328 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
329 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
330
331 ------------------------------------------------------------------------
332 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
333 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
334
335 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
336 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
337 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
338
339 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
340 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
341
342 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
343 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
344
345 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
346 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
347
348 ------------------------------------------------------------------------
349 selectNodesWithParentID :: NodeId -> Query NodeRead
350 selectNodesWithParentID n = proc () -> do
351 row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
352 restrict -< parent_id .== (pgNodeId n)
353 returnA -< row
354
355 selectNodesWithType :: Column PGInt4 -> Query NodeRead
356 selectNodesWithType type_id = proc () -> do
357 row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
358 restrict -< tn .== type_id
359 returnA -< row
360
361 type JSONB = QueryRunnerColumnDefault PGJsonb
362
363 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
364 getNode nId _ = do
365 fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
366 <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
367
368 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
369 getNodesWithType = runOpaQuery . selectNodesWithType
370
371 ------------------------------------------------------------------------
372 ------------------------------------------------------------------------
373 defaultUser :: HyperdataUser
374 defaultUser = HyperdataUser (Just $ (pack . show) EN)
375
376 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
377 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
378 where
379 name = maybe "User" identity maybeName
380 user = maybe defaultUser identity maybeHyperdata
381 ------------------------------------------------------------------------
382 defaultFolder :: HyperdataFolder
383 defaultFolder = HyperdataFolder (Just "Markdown Description")
384
385 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
386 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
387 where
388 name = maybe "Folder" identity maybeName
389 folder = maybe defaultFolder identity maybeFolder
390 ------------------------------------------------------------------------
391 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
392 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
393 where
394 name = maybe "Corpus" identity maybeName
395 corpus = maybe defaultCorpus identity maybeCorpus
396 --------------------------
397 defaultDocument :: HyperdataDocument
398 defaultDocument = hyperdataDocument
399
400 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
401 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
402 where
403 name = maybe "Document" identity maybeName
404 doc = maybe defaultDocument identity maybeDocument
405 ------------------------------------------------------------------------
406 defaultAnnuaire :: HyperdataAnnuaire
407 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
408
409 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
410 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
411 where
412 name = maybe "Annuaire" identity maybeName
413 annuaire = maybe defaultAnnuaire identity maybeAnnuaire
414
415 ------------------------------------------------------------------------
416 arbitraryList :: HyperdataList
417 arbitraryList = HyperdataList (Just "Preferences")
418
419 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
420 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
421 where
422 name = maybe "Listes" identity maybeName
423 list = maybe arbitraryList identity maybeList
424
425 --------------------
426
427 arbitraryListModel :: HyperdataListModel
428 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
429
430 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
431 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
432
433 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
434 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
435 where
436 name = maybe "List Model" identity maybeName
437 list = maybe arbitraryListModel identity maybeListModel
438
439 ------------------------------------------------------------------------
440 arbitraryGraph :: HyperdataGraph
441 arbitraryGraph = HyperdataGraph (Just "Preferences")
442
443 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
444 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
445 where
446 name = maybe "Graph" identity maybeName
447 graph = maybe arbitraryGraph identity maybeGraph
448
449 ------------------------------------------------------------------------
450
451 arbitraryDashboard :: HyperdataDashboard
452 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
453
454 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
455 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
456 where
457 name = maybe "Dashboard" identity maybeName
458 dashboard = maybe arbitraryDashboard identity maybeDashboard
459
460 ------------------------------------------------------------------------
461 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
462 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
463 where
464 typeId = nodeTypeId nodeType
465
466 -------------------------------
467 insertNodes :: [NodeWrite] -> Cmd err Int64
468 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
469
470 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
471 insertNodesR ns = mkCmd $ \conn ->
472 runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
473
474 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
475 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
476
477 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
478 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
479 ------------------------------------------------------------------------
480 -- TODO Hierachy of Nodes
481 -- post and get same types Node' and update if changes
482
483 {- TODO semantic to achieve
484 post c uid pid [ Node' NodeCorpus "name" "{}" []
485 , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
486 , Node' NodeDocument "title" "jsonData" []
487 ]
488 ]
489 ]
490 -}
491 ------------------------------------------------------------------------
492
493 -- TODO
494 -- currently this function removes the child relation
495 -- needs a Temporary type between Node' and NodeWriteT
496 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
497 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
498 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
499
500
501 data Node' = Node' { _n_type :: NodeType
502 , _n_name :: Text
503 , _n_data :: Value
504 , _n_children :: [Node']
505 } deriving (Show)
506
507 mkNode :: [NodeWrite] -> Cmd err Int64
508 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
509
510 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
511 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
512
513 ------------------------------------------------------------------------
514
515 data NewNode = NewNode { _newNodeId :: NodeId
516 , _newNodeChildren :: [NodeId] }
517
518 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
519 postNode uid pid (Node' nt txt v []) = do
520 pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
521 case pids of
522 [pid'] -> pure $ NewNode pid' []
523 _ -> nodeError ManyParents
524
525 postNode uid pid (Node' NodeCorpus txt v ns) = do
526 NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
527 pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
528 pure $ NewNode pid' pids
529
530 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
531 NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
532 pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
533 pure $ NewNode pid' pids
534 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
535
536
537 childWith :: UserId -> ParentId -> Node' -> NodeWrite
538 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
539 childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
540 childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
541
542
543 type Name = Text
544
545 -- | TODO mk all others nodes
546 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
547 mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
548 mkNodeWithParent NodeUser Nothing uId name =
549 insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
550 where
551 hd = HyperdataUser . Just . pack $ show EN
552 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
553 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
554
555
556 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
557 mkRoot uname uId = case uId > 0 of
558 False -> nodeError NegativeId
559 True -> mkNodeWithParent NodeUser Nothing uId uname
560
561 -- |
562 -- CorpusDocument is a corpus made from a set of documents
563 -- CorpusContact is a corpus made from a set of contacts (syn of Annuaire)
564 data CorpusType = CorpusDocument | CorpusContact
565
566 class MkCorpus a
567 where
568 mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
569
570 instance MkCorpus HyperdataCorpus
571 where
572 mk n h p u = insertNodesR [nodeCorpusW n h p u]
573
574
575 instance MkCorpus HyperdataAnnuaire
576 where
577 mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
578
579
580
581
582 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
583 getOrMkList pId uId =
584 maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
585 where
586 mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
587
588 -- | TODO remove defaultList
589 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
590 defaultList cId =
591 maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
592
593 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
594 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
595
596
597 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
598 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
599
600 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
601 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
602
603 -- | Default CorpusId Master and ListId Master
604
605 pgNodeId :: NodeId -> Column PGInt4
606 pgNodeId = pgInt4 . id2int