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