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 HyperdataGraph
  99   where
 100     fromField = fromField'
 101
 102 instance FromField HyperdataAnnuaire
 103   where
 104     fromField = fromField'
 105 ------------------------------------------------------------------------
 106 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
 107   where
 108     queryRunnerColumnDefault = fieldQueryRunnerColumn
 109
 110 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
 111   where
 112     queryRunnerColumnDefault = fieldQueryRunnerColumn
 113
 114 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
 115   where
 116     queryRunnerColumnDefault = fieldQueryRunnerColumn
 117
 118 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
 119   where
 120     queryRunnerColumnDefault = fieldQueryRunnerColumn
 121
 122 instance QueryRunnerColumnDefault PGJsonb HyperdataUser
 123   where
 124     queryRunnerColumnDefault = fieldQueryRunnerColumn
 125
 126 instance QueryRunnerColumnDefault PGJsonb HyperdataList
 127   where
 128     queryRunnerColumnDefault = fieldQueryRunnerColumn
 129
 130 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 131   where
 132     queryRunnerColumnDefault = fieldQueryRunnerColumn
 133
 134 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
 135   where
 136     queryRunnerColumnDefault = fieldQueryRunnerColumn
 137
 138 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
 139   where
 140     queryRunnerColumnDefault = fieldQueryRunnerColumn
 141
 142 instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
 143   where
 144     queryRunnerColumnDefault = fieldQueryRunnerColumn
 145
 146 instance QueryRunnerColumnDefault PGInt4 NodeId
 147   where
 148     queryRunnerColumnDefault = fieldQueryRunnerColumn
 149
 150
 151 ------------------------------------------------------------------------
 152 -- WIP
 153 -- TODO Classe HasDefault where
 154 -- default NodeType = Hyperdata
 155 ------------------------------------------------------------------------
 156 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 157 $(makeLensesWith abbreviatedFields ''NodePoly)
 158
 159 $(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
 160 $(makeLensesWith abbreviatedFields ''NodePolySearch)
 161
 162 type NodeWrite = NodePoly (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 type NodeRead = NodePoly (Column PGInt4        )
 171                          (Column PGInt4        )
 172                          (Column PGInt4        )
 173                          (Column PGInt4        )
 174                          (Column PGText        )
 175                          (Column PGTimestamptz )
 176                          (Column PGJsonb       )
 177
 178 type NodeReadNull = NodePoly (Column (Nullable PGInt4))
 179                              (Column (Nullable PGInt4))
 180                              (Column (Nullable PGInt4))
 181                              (Column (Nullable PGInt4))
 182                              (Column (Nullable PGText))
 183                              (Column (Nullable PGTimestamptz))
 184                              (Column (Nullable PGJsonb))
 185
 186 nodeTable :: Table NodeWrite NodeRead
 187 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
 188                                       , _node_typename   = required "typename"
 189                                       , _node_userId     = required "user_id"
 190
 191                                       , _node_parentId   = optional "parent_id"
 192                                       , _node_name       = required "name"
 193                                       , _node_date       = optional "date"
 194
 195                                       , _node_hyperdata  = required "hyperdata"
 196                                       }
 197                             )
 198
 199 queryNodeTable :: Query NodeRead
 200 queryNodeTable = queryTable nodeTable
 201
 202 ------------------------------------------------------------------------
 203 -- | Node(Read|Write)Search is slower than Node(Write|Read) use it
 204 -- for full text search only
 205 type NodeSearchWrite =
 206   NodePolySearch
 207     (Maybe  (Column  PGInt4)      )
 208     (Column  PGInt4               )
 209     (Column  PGInt4               )
 210     (Column (Nullable PGInt4)     )
 211     (Column PGText                )
 212     (Maybe  (Column PGTimestamptz))
 213     (Column  PGJsonb              )
 214     (Maybe  (Column PGTSVector)   )
 215
 216 type NodeSearchRead =
 217   NodePolySearch
 218     (Column  PGInt4           )
 219     (Column  PGInt4           )
 220     (Column  PGInt4           )
 221     (Column (Nullable PGInt4 ))
 222     (Column  PGText           )
 223     (Column  PGTimestamptz    )
 224     (Column  PGJsonb          )
 225     (Column  PGTSVector       )
 226
 227 type NodeSearchReadNull =
 228   NodePolySearch
 229     (Column (Nullable PGInt4)       )
 230     (Column (Nullable PGInt4)       )
 231     (Column (Nullable PGInt4)       )
 232     (Column (Nullable PGInt4)       )
 233     (Column (Nullable PGText)       )
 234     (Column (Nullable PGTimestamptz))
 235     (Column (Nullable PGJsonb)      )
 236     (Column (Nullable PGTSVector)   )
 237
 238 --{-
 239 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 240 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
 241                                       , _ns_typename   = required "typename"
 242                                       , _ns_userId     = required "user_id"
 243
 244                                       , _ns_parentId   = required "parent_id"
 245                                       , _ns_name       = required "name"
 246                                       , _ns_date       = optional "date"
 247
 248                                       , _ns_hyperdata  = required "hyperdata"
 249                                       , _ns_search     = optional "search"
 250                                       }
 251                             )
 252 --}
 253
 254 queryNodeSearchTable :: Query NodeSearchRead
 255 queryNodeSearchTable = queryTable nodeTableSearch
 256
 257 selectNode :: Column PGInt4 -> Query NodeRead
 258 selectNode id = proc () -> do
 259     row <- queryNodeTable -< ()
 260     restrict -< _node_id row .== id
 261     returnA -< row
 262
 263 runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
 264 runGetNodes = runOpaQuery
 265
 266 ------------------------------------------------------------------------
 267 ------------------------------------------------------------------------
 268
 269 -- | order by publication date
 270 -- Favorites (Bool), node_ngrams
 271 selectNodesWith :: ParentId     -> Maybe NodeType
 272                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 273 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 274         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 275   limit' maybeLimit $ offset' maybeOffset
 276                     $ orderBy (asc _node_id)
 277                     $ selectNodesWith' parentId maybeNodeType
 278
 279 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 280 selectNodesWith' parentId maybeNodeType = proc () -> do
 281     node <- (proc () -> do
 282       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 283       restrict -< parentId' .== (pgNodeId parentId)
 284
 285       let typeId' = maybe 0 nodeTypeId maybeNodeType
 286
 287       restrict -< if typeId' > 0
 288                      then typeId   .== (pgInt4 (typeId' :: Int))
 289                      else (pgBool True)
 290       returnA  -< row ) -< ()
 291     returnA -< node
 292
 293
 294 deleteNode :: NodeId -> Cmd err Int
 295 deleteNode n = mkCmd $ \conn ->
 296   fromIntegral <$> runDelete conn nodeTable
 297                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 298
 299 deleteNodes :: [NodeId] -> Cmd err Int
 300 deleteNodes ns = mkCmd $ \conn ->
 301   fromIntegral <$> runDelete conn nodeTable
 302                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 303
 304 -- TODO: NodeType should match with `a'
 305 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 306              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 307 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 308     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 309
 310 -- TODO: Why is the second parameter ignored?
 311 -- TODO: Why not use getNodesWith?
 312 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
 313 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 314
 315 ------------------------------------------------------------------------
 316 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 317 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 318
 319 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 320 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 321 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 322
 323 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 324 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 325
 326 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 327 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 328
 329 ------------------------------------------------------------------------
 330 selectNodesWithParentID :: NodeId -> Query NodeRead
 331 selectNodesWithParentID n = proc () -> do
 332     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 333     restrict -< parent_id .== (pgNodeId n)
 334     returnA -< row
 335
 336 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 337 selectNodesWithType type_id = proc () -> do
 338     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 339     restrict -< tn .== type_id
 340     returnA -< row
 341
 342 type JSONB = QueryRunnerColumnDefault PGJsonb
 343
 344 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 345 getNode nId _ = do
 346     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 347              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 348
 349 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 350 getNodesWithType = runOpaQuery . selectNodesWithType
 351
 352 ------------------------------------------------------------------------
 353 ------------------------------------------------------------------------
 354 defaultUser :: HyperdataUser
 355 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 356
 357 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 358 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 359   where
 360     name = maybe "User" identity maybeName
 361     user = maybe defaultUser identity maybeHyperdata
 362 ------------------------------------------------------------------------
 363 defaultFolder :: HyperdataFolder
 364 defaultFolder = HyperdataFolder (Just "Markdown Description")
 365
 366 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
 367 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 368   where
 369     name   = maybe "Folder" identity maybeName
 370     folder = maybe defaultFolder identity maybeFolder
 371 ------------------------------------------------------------------------
 372 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 373 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 374   where
 375     name   = maybe "Corpus" identity maybeName
 376     corpus = maybe defaultCorpus identity maybeCorpus
 377                    --------------------------
 378 defaultDocument :: HyperdataDocument
 379 defaultDocument = hyperdataDocument
 380
 381 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 382 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 383   where
 384     name = maybe "Document" identity maybeName
 385     doc  = maybe defaultDocument identity maybeDocument
 386 ------------------------------------------------------------------------
 387 defaultAnnuaire :: HyperdataAnnuaire
 388 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 389
 390 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 391 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 392   where
 393     name     = maybe "Annuaire" identity maybeName
 394     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 395                    --------------------------
 396
 397 ------------------------------------------------------------------------
 398 arbitraryList :: HyperdataList
 399 arbitraryList = HyperdataList (Just "Preferences")
 400
 401 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 402 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 403   where
 404     name = maybe "Listes" identity maybeName
 405     list = maybe arbitraryList identity maybeList
 406
 407 ------------------------------------------------------------------------
 408 arbitraryGraph :: HyperdataGraph
 409 arbitraryGraph = HyperdataGraph (Just "Preferences")
 410
 411 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 412 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 413   where
 414     name = maybe "Graph" identity maybeName
 415     graph = maybe arbitraryGraph identity maybeGraph
 416
 417 ------------------------------------------------------------------------
 418
 419 arbitraryDashboard :: HyperdataDashboard
 420 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 421
 422 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 423 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 424   where
 425     name = maybe "Dashboard" identity maybeName
 426     dashboard = maybe arbitraryDashboard identity maybeDashboard
 427
 428 ------------------------------------------------------------------------
 429 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 430 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 431   where
 432     typeId = nodeTypeId nodeType
 433
 434                   -------------------------------
 435 insertNodes :: [NodeWrite] -> Cmd err Int64
 436 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 437
 438 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 439 insertNodesR ns = mkCmd $ \conn ->
 440   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 441
 442 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 443 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 444
 445 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 446 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 447 ------------------------------------------------------------------------
 448 -- TODO Hierachy of Nodes
 449 -- post and get same types Node' and update if changes
 450
 451 {- TODO semantic to achieve
 452 post c uid pid [ Node' NodeCorpus "name" "{}" []
 453                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 454                                                                     , Node' NodeDocument "title" "jsonData" []
 455                                                                     ]
 456                                           ]
 457                ]
 458 -}
 459 ------------------------------------------------------------------------
 460
 461 -- TODO
 462 -- currently this function removes the child relation
 463 -- needs a Temporary type between Node' and NodeWriteT
 464 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 465 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 466 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 467
 468
 469 data Node' = Node' { _n_type :: NodeType
 470                    , _n_name :: Text
 471                    , _n_data :: Value
 472                    , _n_children :: [Node']
 473                    } deriving (Show)
 474
 475 mkNode :: [NodeWrite] -> Cmd err Int64
 476 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 477
 478 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 479 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 480
 481 ------------------------------------------------------------------------
 482
 483 data NewNode = NewNode { _newNodeId :: NodeId
 484                        , _newNodeChildren :: [NodeId] }
 485
 486 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 487 postNode uid pid (Node' nt txt v []) = do
 488   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 489   case pids of
 490     [pid'] -> pure $ NewNode pid' []
 491     _ -> nodeError ManyParents
 492
 493 postNode uid pid (Node' NodeCorpus txt v ns) = do
 494   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 495   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 496   pure $ NewNode pid' pids
 497
 498 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 499   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 500   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 501   pure $ NewNode pid' pids
 502 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 503
 504
 505 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 506 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 507 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 508 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 509
 510
 511 type Name = Text
 512
 513 -- | TODO mk all others nodes
 514 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 515 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 516 mkNodeWithParent NodeUser Nothing  uId name =
 517   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 518     where
 519       hd = HyperdataUser . Just . pack $ show EN
 520 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 521 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
 522
 523
 524 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 525 mkRoot uname uId = case uId > 0 of
 526                False -> nodeError NegativeId
 527                True  -> mkNodeWithParent NodeUser Nothing uId uname
 528
 529 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [CorpusId]
 530 mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
 531
 532 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 533 getOrMkList pId uId =
 534   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 535     where
 536       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
 537
 538 -- | TODO remove defaultList
 539 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 540 defaultList cId =
 541   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 542
 543 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 544 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 545
 546 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 547 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 548
 549 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 550 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 551
 552 mkAnnuaire :: ParentId -> UserId -> Cmd err [NodeId]
 553 mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
 554
 555 -- | Default CorpusId Master and ListId Master
 556
 557 pgNodeId :: NodeId -> Column PGInt4
 558 pgNodeId = pgInt4 . id2int