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