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