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 {-# LANGUAGE TypeFamilies           #-}
  26
  27 module Gargantext.Database.Schema.Node where
  28
  29 import Control.Arrow (returnA)
  30 import Control.Lens (Prism', set, view, (#), (^?))
  31 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  32 import Control.Monad.Error.Class (MonadError(..))
  33 import Data.Aeson
  34 import Data.Maybe (Maybe(..), fromMaybe)
  35 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  36 import Data.Text (Text)
  37 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  38 import GHC.Int (Int64)
  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, HyperData(..))
  44 import Gargantext.Database.Node.User (HyperdataUser(..), fake_HyperdataUser)
  45 import Gargantext.Database.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
  46 import Gargantext.Database.Utils
  47 import Gargantext.Prelude hiding (sum, head)
  48 import Gargantext.Viz.Graph (HyperdataGraph(..))
  49
  50 import Opaleye hiding (FromField)
  51 import Opaleye.Internal.QueryArr (Query)
  52 import Prelude hiding (null, id, map, sum)
  53
  54 ------------------------------------------------------------------------
  55
  56 data NodeError = NoListFound
  57                | NoRootFound
  58                | NoCorpusFound
  59                | NoUserFound
  60                | MkNode
  61                | UserNoParent
  62                | HasParent
  63                | ManyParents
  64                | NegativeId
  65                | NotImplYet
  66                | ManyNodeUsers
  67   deriving (Show)
  68
  69 class HasNodeError e where
  70   _NodeError :: Prism' e NodeError
  71
  72 nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
  73 nodeError ne = throwError $ _NodeError # ne
  74
  75 catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
  76 catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
  77
  78 ------------------------------------------------------------------------
  79 instance FromField HyperdataAny where
  80     fromField = fromField'
  81
  82 instance FromField HyperdataCorpus
  83   where
  84     fromField = fromField'
  85
  86 instance FromField HyperdataDocument
  87   where
  88     fromField = fromField'
  89
  90 instance FromField HyperdataDocumentV3
  91   where
  92     fromField = fromField'
  93
  94 instance FromField HyperData
  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 HyperdataPhylo
 107   where
 108     fromField = fromField'
 109
 110 instance FromField HyperdataAnnuaire
 111   where
 112     fromField = fromField'
 113
 114 instance FromField HyperdataList
 115   where
 116     fromField = fromField'
 117
 118 instance FromField (NodeId, Text)
 119   where
 120     fromField = fromField'
 121 ------------------------------------------------------------------------
 122 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
 123   where
 124     queryRunnerColumnDefault = fieldQueryRunnerColumn
 125
 126 instance QueryRunnerColumnDefault PGJsonb HyperdataList
 127   where
 128     queryRunnerColumnDefault = fieldQueryRunnerColumn
 129
 130 instance QueryRunnerColumnDefault PGJsonb HyperData
 131   where
 132     queryRunnerColumnDefault = fieldQueryRunnerColumn
 133
 134
 135 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
 136   where
 137     queryRunnerColumnDefault = fieldQueryRunnerColumn
 138
 139 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
 140   where
 141     queryRunnerColumnDefault = fieldQueryRunnerColumn
 142
 143 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
 144   where
 145     queryRunnerColumnDefault = fieldQueryRunnerColumn
 146
 147 instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
 148   where
 149     queryRunnerColumnDefault = fieldQueryRunnerColumn
 150
 151 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 152   where
 153     queryRunnerColumnDefault = fieldQueryRunnerColumn
 154
 155 instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
 156   where
 157     queryRunnerColumnDefault = fieldQueryRunnerColumn
 158
 159 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
 160   where
 161     queryRunnerColumnDefault = fieldQueryRunnerColumn
 162
 163 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
 164   where
 165     queryRunnerColumnDefault = fieldQueryRunnerColumn
 166
 167 instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
 168   where
 169     queryRunnerColumnDefault = fieldQueryRunnerColumn
 170
 171 instance QueryRunnerColumnDefault PGInt4 NodeId
 172   where
 173     queryRunnerColumnDefault = fieldQueryRunnerColumn
 174
 175 instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
 176   where
 177     queryRunnerColumnDefault = fieldQueryRunnerColumn
 178
 179
 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 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 264 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
 265                                       , _ns_typename   = required "typename"
 266                                       , _ns_userId     = required "user_id"
 267
 268                                       , _ns_parentId   = required "parent_id"
 269                                       , _ns_name       = required "name"
 270                                       , _ns_date       = optional "date"
 271
 272                                       , _ns_hyperdata  = required "hyperdata"
 273                                       , _ns_search     = optional "search"
 274                                       }
 275                             )
 276
 277
 278 queryNodeSearchTable :: Query NodeSearchRead
 279 queryNodeSearchTable = queryTable nodeTableSearch
 280
 281 selectNode :: Column PGInt4 -> Query NodeRead
 282 selectNode id = proc () -> do
 283     row <- queryNodeTable -< ()
 284     restrict -< _node_id row .== id
 285     returnA -< row
 286
 287
 288
 289 runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
 290 runGetNodes = runOpaQuery
 291
 292 ------------------------------------------------------------------------
 293 ------------------------------------------------------------------------
 294 -- | order by publication date
 295 -- Favorites (Bool), node_ngrams
 296 selectNodesWith :: ParentId     -> Maybe NodeType
 297                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 298 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 299         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 300   limit' maybeLimit $ offset' maybeOffset
 301                     $ orderBy (asc _node_id)
 302                     $ selectNodesWith' parentId maybeNodeType
 303
 304 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 305 selectNodesWith' parentId maybeNodeType = proc () -> do
 306     node <- (proc () -> do
 307       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 308       restrict -< parentId' .== (pgNodeId parentId)
 309
 310       let typeId' = maybe 0 nodeTypeId maybeNodeType
 311
 312       restrict -< if typeId' > 0
 313                      then typeId   .== (pgInt4 (typeId' :: Int))
 314                      else (pgBool True)
 315       returnA  -< row ) -< ()
 316     returnA -< node
 317
 318 deleteNode :: NodeId -> Cmd err Int
 319 deleteNode n = mkCmd $ \conn ->
 320   fromIntegral <$> runDelete conn nodeTable
 321                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 322
 323 deleteNodes :: [NodeId] -> Cmd err Int
 324 deleteNodes ns = mkCmd $ \conn ->
 325   fromIntegral <$> runDelete conn nodeTable
 326                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 327
 328 -- TODO: NodeType should match with `a'
 329 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 330              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 331 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 332     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 333
 334 -- TODO: Why is the second parameter ignored?
 335 -- TODO: Why not use getNodesWith?
 336 getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
 337                      => Maybe NodeId
 338                      -> Cmd err [Node a]
 339 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 340   where
 341     n' = case n of
 342       Just n'' -> n''
 343       Nothing  -> 0
 344
 345 ------------------------------------------------------------------------
 346 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 347 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 348
 349 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 350 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 351 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 352
 353 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 354 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 355
 356 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 357 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 358
 359 ------------------------------------------------------------------------
 360 selectNodesWithParentID :: NodeId -> Query NodeRead
 361 selectNodesWithParentID n = proc () -> do
 362     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 363     restrict -< parent_id .== (pgNodeId n)
 364     returnA -< row
 365
 366 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 367 selectNodesWithType type_id = proc () -> do
 368     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 369     restrict -< tn .== type_id
 370     returnA -< row
 371
 372 type JSONB = QueryRunnerColumnDefault PGJsonb
 373
 374
 375 getNode :: NodeId -> Cmd err (Node Value)
 376 getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 377              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 378
 379 getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 380 getNodeWith nId _ = do
 381     fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 382              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 383
 384 getNodeUser :: NodeId -> Cmd err (Node HyperdataUser)
 385 getNodeUser nId = do
 386     fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 387              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 388
 389
 390 getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
 391 getNodePhylo nId = do
 392     fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
 393              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 394
 395
 396 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 397 getNodesWithType = runOpaQuery . selectNodesWithType
 398
 399 ------------------------------------------------------------------------
 400 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 401 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 402   where
 403     name = maybe "User" identity maybeName
 404     user = maybe fake_HyperdataUser identity maybeHyperdata
 405
 406 nodeContactW :: Maybe Name -> Maybe HyperdataContact
 407              -> AnnuaireId -> UserId -> NodeWrite
 408 nodeContactW maybeName maybeContact aId =
 409   node NodeContact name contact (Just aId)
 410     where
 411       name    = maybe "Contact" identity maybeName
 412       contact = maybe arbitraryHyperdataContact identity maybeContact
 413 ------------------------------------------------------------------------
 414 defaultFolder :: HyperdataCorpus
 415 defaultFolder = defaultCorpus
 416
 417 nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 418 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 419   where
 420     name   = maybe "Folder" identity maybeName
 421     folder = maybe defaultFolder identity maybeFolder
 422 ------------------------------------------------------------------------
 423 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 424 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 425   where
 426     name   = maybe "Corpus" identity maybeName
 427     corpus = maybe defaultCorpus identity maybeCorpus
 428                    --------------------------
 429 defaultDocument :: HyperdataDocument
 430 defaultDocument = hyperdataDocument
 431
 432 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 433 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 434   where
 435     name = maybe "Document" identity maybeName
 436     doc  = maybe defaultDocument identity maybeDocument
 437 ------------------------------------------------------------------------
 438 defaultAnnuaire :: HyperdataAnnuaire
 439 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 440
 441 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 442 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 443   where
 444     name     = maybe "Annuaire" identity maybeName
 445     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 446
 447 ------------------------------------------------------------------------
 448
 449 {-
 450 class IsNodeDb a where
 451   data Node'' a :: *
 452   data Hyper  a :: *
 453
 454 instance IsNodeDb NodeType where
 455   data
 456
 457 instance HasHyperdata NodeType where
 458   data Hyper NodeType = HyperList   HyperdataList
 459                       | HyperCorpus HyperdataCorpus
 460
 461   hasHyperdata nt = case nt of
 462     NodeList   -> HyperList $ HyperdataList (Just "list")
 463
 464   unHyper h = case h of
 465     HyperList h' -> h'
 466
 467 --}
 468
 469
 470 class HasDefault a where
 471   hasDefaultData :: a -> HyperData
 472   hasDefaultName :: a -> Text
 473
 474 instance HasDefault NodeType where
 475   hasDefaultData nt = case nt of
 476       NodeTexts -> HyperdataTexts (Just "Preferences")
 477       NodeList  -> HyperdataList' (Just "Preferences")
 478       NodeListCooc -> HyperdataList' (Just "Preferences")
 479       _         -> undefined
 480       --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
 481
 482   hasDefaultName nt = case nt of
 483       NodeTexts -> "Texts"
 484       NodeList  -> "Lists"
 485       NodeListCooc -> "Cooc"
 486       _         -> undefined
 487
 488 ------------------------------------------------------------------------
 489
 490 nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
 491 nodeDefault nt parent = node nt name hyper (Just parent)
 492   where
 493     name  = (hasDefaultName nt)
 494     hyper = (hasDefaultData nt)
 495
 496 ------------------------------------------------------------------------
 497 arbitraryListModel :: HyperdataListModel
 498 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 499
 500 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 501 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 502
 503 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 504 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 505   where
 506     name = maybe "List Model" identity maybeName
 507     list = maybe arbitraryListModel identity maybeListModel
 508
 509 ------------------------------------------------------------------------
 510 arbitraryGraph :: HyperdataGraph
 511 arbitraryGraph = HyperdataGraph Nothing
 512
 513 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 514 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 515   where
 516     name = maybe "Graph" identity maybeName
 517     graph = maybe arbitraryGraph identity maybeGraph
 518
 519 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 520 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 521
 522 insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
 523 insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
 524
 525 ------------------------------------------------------------------------
 526 arbitraryPhylo :: HyperdataPhylo
 527 arbitraryPhylo = HyperdataPhylo Nothing Nothing
 528
 529 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 530 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 531   where
 532     name = maybe "Phylo" identity maybeName
 533     graph = maybe arbitraryPhylo identity maybePhylo
 534
 535
 536 ------------------------------------------------------------------------
 537 arbitraryDashboard :: HyperdataDashboard
 538 arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
 539 ------------------------------------------------------------------------
 540
 541 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 542 node nodeType name hyperData parentId userId =
 543   Node Nothing
 544        (pgInt4 typeId)
 545        (pgInt4 userId)
 546        (pgNodeId <$> parentId)
 547        (pgStrictText name)
 548        Nothing
 549        (pgJSONB $ cs $ encode hyperData)
 550     where
 551       typeId = nodeTypeId nodeType
 552
 553                   -------------------------------
 554 insertNodes :: [NodeWrite] -> Cmd err Int64
 555 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 556
 557 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 558 insertNodesR ns = mkCmd $ \conn ->
 559   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 560
 561 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 562 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 563
 564 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 565 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 566 ------------------------------------------------------------------------
 567 -- TODO Hierachy of Nodes
 568 -- post and get same types Node' and update if changes
 569
 570 {- TODO semantic to achieve
 571 post c uid pid [ Node' NodeCorpus "name" "{}" []
 572                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 573                                                                     , Node' NodeDocument "title" "jsonData" []
 574                                                                     ]
 575                                           ]
 576                ]
 577 -}
 578 ------------------------------------------------------------------------
 579
 580 -- TODO
 581 -- currently this function removes the child relation
 582 -- needs a Temporary type between Node' and NodeWriteT
 583 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 584 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 585 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 586
 587
 588 data Node' = Node' { _n_type :: NodeType
 589                    , _n_name :: Text
 590                    , _n_data :: Value
 591                    , _n_children :: [Node']
 592                    } deriving (Show)
 593
 594 mkNodes :: [NodeWrite] -> Cmd err Int64
 595 mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 596
 597 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 598 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 599
 600 ------------------------------------------------------------------------
 601
 602 data NewNode = NewNode { _newNodeId :: NodeId
 603                        , _newNodeChildren :: [NodeId] }
 604
 605 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 606
 607 postNode uid pid (Node' nt txt v []) = do
 608   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 609   case pids of
 610     [pid'] -> pure $ NewNode pid' []
 611     _ -> nodeError ManyParents
 612
 613 postNode uid pid (Node' NodeCorpus txt v ns) = do
 614   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 615   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 616   pure $ NewNode pid' pids
 617
 618 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 619   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 620   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 621   pure $ NewNode pid' pids
 622
 623 postNode uid pid (Node' NodeDashboard txt v ns) = do
 624   NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
 625   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 626   pure $ NewNode pid' pids
 627
 628 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 629
 630
 631 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 632 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 633 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 634 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 635
 636
 637 -- =================================================================== --
 638 ------------------------------------------------------------------------
 639 -- | TODO mk all others nodes
 640 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 641 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 642
 643 ------------------------------------------------------------------------
 644 mkNodeWithParent NodeUser Nothing  uId name =
 645   insertNodesWithParentR Nothing [node NodeUser name fake_HyperdataUser Nothing uId]
 646
 647 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 648 ------------------------------------------------------------------------
 649 mkNodeWithParent NodeFolder (Just i) uId name =
 650    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
 651     where
 652       hd = defaultFolder
 653
 654 mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
 655    insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
 656     where
 657       hd = defaultFolder
 658
 659 mkNodeWithParent NodeFolderShared (Just i) uId _ =
 660    insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
 661     where
 662       hd = defaultFolder
 663
 664 mkNodeWithParent NodeFolderPublic (Just i) uId _ =
 665    insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
 666     where
 667       hd = defaultFolder
 668
 669 mkNodeWithParent NodeTeam (Just i) uId _ =
 670    insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
 671     where
 672       hd = defaultFolder
 673 ------------------------------------------------------------------------
 674 mkNodeWithParent NodeCorpus (Just i) uId name =
 675    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
 676     where
 677       hd = defaultCorpus
 678
 679 mkNodeWithParent NodeAnnuaire (Just i) uId name =
 680    insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
 681     where
 682       hd = defaultAnnuaire
 683
 684 mkNodeWithParent _ _ _ _       = nodeError NotImplYet
 685 ------------------------------------------------------------------------
 686 -- =================================================================== --
 687
 688
 689
 690 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 691 mkRoot uname uId = case uId > 0 of
 692                False -> nodeError NegativeId
 693                True  -> do
 694                  rs <- mkNodeWithParent NodeUser Nothing uId uname
 695                  _ <- case rs of
 696                    [r] -> do
 697                      _ <- mkNodeWithParent NodeFolderPrivate (Just r) uId uname
 698                      _ <- mkNodeWithParent NodeFolderShared  (Just r) uId uname
 699                      _ <- mkNodeWithParent NodeFolderPublic  (Just r) uId uname
 700                      pure rs
 701                    _   -> pure rs
 702                  pure rs
 703
 704 -- |
 705 -- CorpusDocument is a corpus made from a set of documents
 706 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 707 data CorpusType = CorpusDocument | CorpusContact
 708
 709 class MkCorpus a
 710   where
 711     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 712
 713 instance MkCorpus HyperdataCorpus
 714   where
 715     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 716
 717
 718 instance MkCorpus HyperdataAnnuaire
 719   where
 720     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 721
 722
 723 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 724 getOrMkList pId uId =
 725   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 726     where
 727       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 728
 729 -- | TODO remove defaultList
 730 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 731 defaultList cId =
 732   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 733
 734 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 735 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 736
 737 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 738 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 739   where
 740     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 741     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 742       where
 743         name = maybe "Board" identity maybeName
 744         dashboard = maybe arbitraryDashboard identity maybeDashboard
 745
 746
 747 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 748 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 749
 750 -- | Default CorpusId Master and ListId Master
 751
 752 pgNodeId :: NodeId -> Column PGInt4
 753 pgNodeId = pgInt4 . id2int
 754
 755 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 756 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 757
 758
 759 -- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 760 -- updateNodeUser_fake :: NodeId -> Cmd err Int64
 761 -- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
 762
 763