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