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 getNode' :: NodeId -> Cmd err (Node Value)
 370 getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 371              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 372
 373
 374 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 375 getNodesWithType = runOpaQuery . selectNodesWithType
 376
 377 ------------------------------------------------------------------------
 378 ------------------------------------------------------------------------
 379 defaultUser :: HyperdataUser
 380 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 381
 382 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 383 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 384   where
 385     name = maybe "User" identity maybeName
 386     user = maybe defaultUser identity maybeHyperdata
 387 ------------------------------------------------------------------------
 388 defaultFolder :: HyperdataFolder
 389 defaultFolder = HyperdataFolder (Just "Markdown Description")
 390
 391 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
 392 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 393   where
 394     name   = maybe "Folder" identity maybeName
 395     folder = maybe defaultFolder identity maybeFolder
 396 ------------------------------------------------------------------------
 397 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 398 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 399   where
 400     name   = maybe "Corpus" identity maybeName
 401     corpus = maybe defaultCorpus identity maybeCorpus
 402                    --------------------------
 403 defaultDocument :: HyperdataDocument
 404 defaultDocument = hyperdataDocument
 405
 406 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 407 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 408   where
 409     name = maybe "Document" identity maybeName
 410     doc  = maybe defaultDocument identity maybeDocument
 411 ------------------------------------------------------------------------
 412 defaultAnnuaire :: HyperdataAnnuaire
 413 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 414
 415 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 416 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 417   where
 418     name     = maybe "Annuaire" identity maybeName
 419     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 420
 421 ------------------------------------------------------------------------
 422 arbitraryList :: HyperdataList
 423 arbitraryList = HyperdataList (Just "Preferences")
 424
 425 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 426 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 427   where
 428     name = maybe "Listes" identity maybeName
 429     list = maybe arbitraryList identity maybeList
 430
 431                 --------------------
 432
 433 arbitraryListModel :: HyperdataListModel
 434 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 435
 436 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 437 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 438
 439 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 440 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 441   where
 442     name = maybe "List Model" identity maybeName
 443     list = maybe arbitraryListModel identity maybeListModel
 444
 445 ------------------------------------------------------------------------
 446 arbitraryGraph :: HyperdataGraph
 447 arbitraryGraph = HyperdataGraph (Just "Preferences")
 448
 449 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 450 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 451   where
 452     name = maybe "Graph" identity maybeName
 453     graph = maybe arbitraryGraph identity maybeGraph
 454
 455 ------------------------------------------------------------------------
 456
 457 arbitraryDashboard :: HyperdataDashboard
 458 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 459
 460 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 461 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 462   where
 463     name = maybe "Dashboard" identity maybeName
 464     dashboard = maybe arbitraryDashboard identity maybeDashboard
 465
 466 ------------------------------------------------------------------------
 467 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 468 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 469   where
 470     typeId = nodeTypeId nodeType
 471
 472                   -------------------------------
 473 insertNodes :: [NodeWrite] -> Cmd err Int64
 474 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 475
 476 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 477 insertNodesR ns = mkCmd $ \conn ->
 478   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 479
 480 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 481 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 482
 483 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 484 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 485 ------------------------------------------------------------------------
 486 -- TODO Hierachy of Nodes
 487 -- post and get same types Node' and update if changes
 488
 489 {- TODO semantic to achieve
 490 post c uid pid [ Node' NodeCorpus "name" "{}" []
 491                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 492                                                                     , Node' NodeDocument "title" "jsonData" []
 493                                                                     ]
 494                                           ]
 495                ]
 496 -}
 497 ------------------------------------------------------------------------
 498
 499 -- TODO
 500 -- currently this function removes the child relation
 501 -- needs a Temporary type between Node' and NodeWriteT
 502 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 503 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 504 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 505
 506
 507 data Node' = Node' { _n_type :: NodeType
 508                    , _n_name :: Text
 509                    , _n_data :: Value
 510                    , _n_children :: [Node']
 511                    } deriving (Show)
 512
 513 mkNode :: [NodeWrite] -> Cmd err Int64
 514 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 515
 516 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 517 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 518
 519 ------------------------------------------------------------------------
 520
 521 data NewNode = NewNode { _newNodeId :: NodeId
 522                        , _newNodeChildren :: [NodeId] }
 523
 524 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 525 postNode uid pid (Node' nt txt v []) = do
 526   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 527   case pids of
 528     [pid'] -> pure $ NewNode pid' []
 529     _ -> nodeError ManyParents
 530
 531 postNode uid pid (Node' NodeCorpus txt v ns) = do
 532   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 533   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 534   pure $ NewNode pid' pids
 535
 536 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 537   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 538   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 539   pure $ NewNode pid' pids
 540 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 541
 542
 543 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 544 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 545 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 546 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 547
 548
 549 type Name = Text
 550
 551 -- | TODO mk all others nodes
 552 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 553 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 554 mkNodeWithParent NodeUser Nothing  uId name =
 555   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 556     where
 557       hd = HyperdataUser . Just . pack $ show EN
 558 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 559 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
 560
 561
 562 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 563 mkRoot uname uId = case uId > 0 of
 564                False -> nodeError NegativeId
 565                True  -> mkNodeWithParent NodeUser Nothing uId uname
 566
 567 -- |
 568 -- CorpusDocument is a corpus made from a set of documents
 569 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 570 data CorpusType = CorpusDocument | CorpusContact
 571
 572 class MkCorpus a
 573   where
 574     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 575
 576 instance MkCorpus HyperdataCorpus
 577   where
 578     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 579
 580
 581 instance MkCorpus HyperdataAnnuaire
 582   where
 583     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 584
 585
 586 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 587 getOrMkList pId uId =
 588   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 589     where
 590       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
 591
 592 -- | TODO remove defaultList
 593 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 594 defaultList cId =
 595   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 596
 597 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 598 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 599
 600 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 601 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 602
 603 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 604 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 605
 606 -- | Default CorpusId Master and ListId Master
 607
 608 pgNodeId :: NodeId -> Column PGInt4
 609 pgNodeId = pgInt4 . id2int