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
 280
 281 runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
 282 runGetNodes = runOpaQuery
 283
 284 ------------------------------------------------------------------------
 285 ------------------------------------------------------------------------
 286
 287 -- | order by publication date
 288 -- Favorites (Bool), node_ngrams
 289 selectNodesWith :: ParentId     -> Maybe NodeType
 290                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 291 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 292         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 293   limit' maybeLimit $ offset' maybeOffset
 294                     $ orderBy (asc _node_id)
 295                     $ selectNodesWith' parentId maybeNodeType
 296
 297 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 298 selectNodesWith' parentId maybeNodeType = proc () -> do
 299     node <- (proc () -> do
 300       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 301       restrict -< parentId' .== (pgNodeId parentId)
 302
 303       let typeId' = maybe 0 nodeTypeId maybeNodeType
 304
 305       restrict -< if typeId' > 0
 306                      then typeId   .== (pgInt4 (typeId' :: Int))
 307                      else (pgBool True)
 308       returnA  -< row ) -< ()
 309     returnA -< node
 310
 311 deleteNode :: NodeId -> Cmd err Int
 312 deleteNode n = mkCmd $ \conn ->
 313   fromIntegral <$> runDelete conn nodeTable
 314                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 315
 316 deleteNodes :: [NodeId] -> Cmd err Int
 317 deleteNodes ns = mkCmd $ \conn ->
 318   fromIntegral <$> runDelete conn nodeTable
 319                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 320
 321 -- TODO: NodeType should match with `a'
 322 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 323              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 324 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 325     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 326
 327 -- TODO: Why is the second parameter ignored?
 328 -- TODO: Why not use getNodesWith?
 329 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
 330 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 331
 332 ------------------------------------------------------------------------
 333 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 334 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 335
 336 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 337 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 338 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 339
 340 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 341 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 342
 343 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 344 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 345
 346 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 347 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 348
 349 ------------------------------------------------------------------------
 350 selectNodesWithParentID :: NodeId -> Query NodeRead
 351 selectNodesWithParentID n = proc () -> do
 352     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 353     restrict -< parent_id .== (pgNodeId n)
 354     returnA -< row
 355
 356 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 357 selectNodesWithType type_id = proc () -> do
 358     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 359     restrict -< tn .== type_id
 360     returnA -< row
 361
 362 type JSONB = QueryRunnerColumnDefault PGJsonb
 363
 364 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 365 getNode nId _ = do
 366     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 367              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 368
 369 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 370 getNodesWithType = runOpaQuery . selectNodesWithType
 371
 372 ------------------------------------------------------------------------
 373 ------------------------------------------------------------------------
 374 defaultUser :: HyperdataUser
 375 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 376
 377 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 378 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 379   where
 380     name = maybe "User" identity maybeName
 381     user = maybe defaultUser identity maybeHyperdata
 382 ------------------------------------------------------------------------
 383 defaultFolder :: HyperdataFolder
 384 defaultFolder = HyperdataFolder (Just "Markdown Description")
 385
 386 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
 387 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 388   where
 389     name   = maybe "Folder" identity maybeName
 390     folder = maybe defaultFolder identity maybeFolder
 391 ------------------------------------------------------------------------
 392 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 393 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 394   where
 395     name   = maybe "Corpus" identity maybeName
 396     corpus = maybe defaultCorpus identity maybeCorpus
 397                    --------------------------
 398 defaultDocument :: HyperdataDocument
 399 defaultDocument = hyperdataDocument
 400
 401 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 402 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 403   where
 404     name = maybe "Document" identity maybeName
 405     doc  = maybe defaultDocument identity maybeDocument
 406 ------------------------------------------------------------------------
 407 defaultAnnuaire :: HyperdataAnnuaire
 408 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 409
 410 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 411 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 412   where
 413     name     = maybe "Annuaire" identity maybeName
 414     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 415
 416 ------------------------------------------------------------------------
 417 arbitraryList :: HyperdataList
 418 arbitraryList = HyperdataList (Just "Preferences")
 419
 420 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 421 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 422   where
 423     name = maybe "Listes" identity maybeName
 424     list = maybe arbitraryList identity maybeList
 425
 426                 --------------------
 427
 428 arbitraryListModel :: HyperdataListModel
 429 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 430
 431 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 432 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 433
 434 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 435 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 436   where
 437     name = maybe "List Model" identity maybeName
 438     list = maybe arbitraryListModel identity maybeListModel
 439
 440 ------------------------------------------------------------------------
 441 arbitraryGraph :: HyperdataGraph
 442 arbitraryGraph = HyperdataGraph (Just "Preferences")
 443
 444 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 445 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 446   where
 447     name = maybe "Graph" identity maybeName
 448     graph = maybe arbitraryGraph identity maybeGraph
 449
 450 ------------------------------------------------------------------------
 451
 452 arbitraryDashboard :: HyperdataDashboard
 453 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 454
 455 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 456 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 457   where
 458     name = maybe "Dashboard" identity maybeName
 459     dashboard = maybe arbitraryDashboard identity maybeDashboard
 460
 461 ------------------------------------------------------------------------
 462 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 463 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 464   where
 465     typeId = nodeTypeId nodeType
 466
 467                   -------------------------------
 468 insertNodes :: [NodeWrite] -> Cmd err Int64
 469 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 470
 471 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 472 insertNodesR ns = mkCmd $ \conn ->
 473   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 474
 475 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 476 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 477
 478 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 479 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 480 ------------------------------------------------------------------------
 481 -- TODO Hierachy of Nodes
 482 -- post and get same types Node' and update if changes
 483
 484 {- TODO semantic to achieve
 485 post c uid pid [ Node' NodeCorpus "name" "{}" []
 486                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 487                                                                     , Node' NodeDocument "title" "jsonData" []
 488                                                                     ]
 489                                           ]
 490                ]
 491 -}
 492 ------------------------------------------------------------------------
 493
 494 -- TODO
 495 -- currently this function removes the child relation
 496 -- needs a Temporary type between Node' and NodeWriteT
 497 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 498 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 499 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 500
 501
 502 data Node' = Node' { _n_type :: NodeType
 503                    , _n_name :: Text
 504                    , _n_data :: Value
 505                    , _n_children :: [Node']
 506                    } deriving (Show)
 507
 508 mkNode :: [NodeWrite] -> Cmd err Int64
 509 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 510
 511 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 512 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 513
 514 ------------------------------------------------------------------------
 515
 516 data NewNode = NewNode { _newNodeId :: NodeId
 517                        , _newNodeChildren :: [NodeId] }
 518
 519 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 520 postNode uid pid (Node' nt txt v []) = do
 521   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 522   case pids of
 523     [pid'] -> pure $ NewNode pid' []
 524     _ -> nodeError ManyParents
 525
 526 postNode uid pid (Node' NodeCorpus txt v ns) = do
 527   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 528   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 529   pure $ NewNode pid' pids
 530
 531 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 532   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 533   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 534   pure $ NewNode pid' pids
 535 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 536
 537
 538 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 539 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 540 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 541 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 542
 543
 544 type Name = Text
 545
 546 -- | TODO mk all others nodes
 547 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 548 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 549 mkNodeWithParent NodeUser Nothing  uId name =
 550   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 551     where
 552       hd = HyperdataUser . Just . pack $ show EN
 553 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 554 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
 555
 556
 557 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 558 mkRoot uname uId = case uId > 0 of
 559                False -> nodeError NegativeId
 560                True  -> mkNodeWithParent NodeUser Nothing uId uname
 561
 562 -- |
 563 -- CorpusDocument is a corpus made from a set of documents
 564 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 565 data CorpusType = CorpusDocument | CorpusContact
 566
 567 class MkCorpus a
 568   where
 569     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 570
 571 instance MkCorpus HyperdataCorpus
 572   where
 573     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 574
 575
 576 instance MkCorpus HyperdataAnnuaire
 577   where
 578     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 579
 580
 581
 582
 583 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 584 getOrMkList pId uId =
 585   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 586     where
 587       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
 588
 589 -- | TODO remove defaultList
 590 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 591 defaultList cId =
 592   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 593
 594 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 595 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 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