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