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