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