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 queryNodeSearchTable :: Query NodeSearchRead
 285 queryNodeSearchTable = queryTable nodeTableSearch
 286
 287 selectNode :: Column PGInt4 -> Query NodeRead
 288 selectNode id = proc () -> do
 289     row <- queryNodeTable -< ()
 290     restrict -< _node_id row .== id
 291     returnA -< row
 292
 293
 294
 295 runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
 296 runGetNodes = runOpaQuery
 297
 298 ------------------------------------------------------------------------
 299 ------------------------------------------------------------------------
 300 -- | order by publication date
 301 -- Favorites (Bool), node_ngrams
 302 selectNodesWith :: ParentId     -> Maybe NodeType
 303                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 304 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 305         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 306   limit' maybeLimit $ offset' maybeOffset
 307                     $ orderBy (asc _node_id)
 308                     $ selectNodesWith' parentId maybeNodeType
 309
 310 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 311 selectNodesWith' parentId maybeNodeType = proc () -> do
 312     node <- (proc () -> do
 313       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 314       restrict -< parentId' .== (pgNodeId parentId)
 315
 316       let typeId' = maybe 0 nodeTypeId maybeNodeType
 317
 318       restrict -< if typeId' > 0
 319                      then typeId   .== (pgInt4 (typeId' :: Int))
 320                      else (pgBool True)
 321       returnA  -< row ) -< ()
 322     returnA -< node
 323
 324 deleteNode :: NodeId -> Cmd err Int
 325 deleteNode n = mkCmd $ \conn ->
 326   fromIntegral <$> runDelete conn nodeTable
 327                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 328
 329 deleteNodes :: [NodeId] -> Cmd err Int
 330 deleteNodes ns = mkCmd $ \conn ->
 331   fromIntegral <$> runDelete conn nodeTable
 332                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 333
 334 -- TODO: NodeType should match with `a'
 335 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 336              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 337 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 338     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 339
 340 -- TODO: Why is the second parameter ignored?
 341 -- TODO: Why not use getNodesWith?
 342 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [Node HyperdataAny]
 343 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 344
 345 ------------------------------------------------------------------------
 346 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 347 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 348
 349 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 350 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 351 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 352
 353 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 354 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 355
 356 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 357 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 358
 359 ------------------------------------------------------------------------
 360 selectNodesWithParentID :: NodeId -> Query NodeRead
 361 selectNodesWithParentID n = proc () -> do
 362     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 363     restrict -< parent_id .== (pgNodeId n)
 364     returnA -< row
 365
 366 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 367 selectNodesWithType type_id = proc () -> do
 368     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 369     restrict -< tn .== type_id
 370     returnA -< row
 371
 372 type JSONB = QueryRunnerColumnDefault PGJsonb
 373
 374 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 375 getNode nId _ = do
 376     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 377              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 378
 379 getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
 380 getNodePhylo nId = do
 381     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 382              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 383
 384
 385 getNode' :: NodeId -> Cmd err (Node Value)
 386 getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 387              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 388
 389
 390 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 391 getNodesWithType = runOpaQuery . selectNodesWithType
 392
 393 ------------------------------------------------------------------------
 394 defaultUser :: HyperdataUser
 395 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 396
 397 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 398 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 399   where
 400     name = maybe "User" identity maybeName
 401     user = maybe defaultUser identity maybeHyperdata
 402 ------------------------------------------------------------------------
 403 defaultFolder :: HyperdataFolder
 404 defaultFolder = HyperdataFolder (Just "Markdown Description")
 405
 406 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
 407 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 408   where
 409     name   = maybe "Folder" identity maybeName
 410     folder = maybe defaultFolder identity maybeFolder
 411 ------------------------------------------------------------------------
 412 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 413 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 414   where
 415     name   = maybe "Corpus" identity maybeName
 416     corpus = maybe defaultCorpus identity maybeCorpus
 417                    --------------------------
 418 defaultDocument :: HyperdataDocument
 419 defaultDocument = hyperdataDocument
 420
 421 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 422 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 423   where
 424     name = maybe "Document" identity maybeName
 425     doc  = maybe defaultDocument identity maybeDocument
 426 ------------------------------------------------------------------------
 427 defaultAnnuaire :: HyperdataAnnuaire
 428 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 429
 430 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 431 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 432   where
 433     name     = maybe "Annuaire" identity maybeName
 434     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 435
 436 ------------------------------------------------------------------------
 437
 438 {-
 439 class IsNodeDb a where
 440   data Node'' a :: *
 441   data Hyper  a :: *
 442
 443 instance IsNodeDb NodeType where
 444   data
 445
 446 instance HasHyperdata NodeType where
 447   data Hyper NodeType = HyperList   HyperdataList
 448                       | HyperCorpus HyperdataCorpus
 449
 450   hasHyperdata nt = case nt of
 451     NodeList   -> HyperList $ HyperdataList (Just "list")
 452
 453   unHyper h = case h of
 454     HyperList h' -> h'
 455
 456 --}
 457
 458
 459 class HasDefault a where
 460   hasDefaultData :: a -> HyperData
 461   hasDefaultName :: a -> Text
 462
 463 instance HasDefault NodeType where
 464   hasDefaultData nt = case nt of
 465       NodeTexts -> HyperdataTexts (Just "Preferences")
 466       NodeList  -> HyperdataList' (Just "Preferences")
 467       _         -> undefined
 468       --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
 469
 470   hasDefaultName nt = case nt of
 471       NodeTexts -> "Texts"
 472       NodeList  -> "Lists"
 473       _         -> undefined
 474
 475 ------------------------------------------------------------------------
 476
 477 nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
 478 nodeDefault nt parent = node nt name hyper (Just parent)
 479   where
 480     name  = (hasDefaultName nt)
 481     hyper = (hasDefaultData nt)
 482
 483 ------------------------------------------------------------------------
 484
 485 arbitraryListModel :: HyperdataListModel
 486 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 487
 488 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 489 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 490
 491 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 492 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 493   where
 494     name = maybe "List Model" identity maybeName
 495     list = maybe arbitraryListModel identity maybeListModel
 496
 497 ------------------------------------------------------------------------
 498 arbitraryGraph :: HyperdataGraph
 499 arbitraryGraph = HyperdataGraph Nothing
 500
 501 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 502 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 503   where
 504     name = maybe "Graph" identity maybeName
 505     graph = maybe arbitraryGraph identity maybeGraph
 506
 507 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 508 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 509
 510 insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
 511 insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
 512
 513 ------------------------------------------------------------------------
 514 arbitraryPhylo :: HyperdataPhylo
 515 arbitraryPhylo = HyperdataPhylo Nothing Nothing
 516
 517 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 518 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 519   where
 520     name = maybe "Phylo" identity maybeName
 521     graph = maybe arbitraryPhylo identity maybePhylo
 522
 523
 524 ------------------------------------------------------------------------
 525 arbitraryDashboard :: HyperdataDashboard
 526 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 527 ------------------------------------------------------------------------
 528
 529 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 530 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 531   where
 532     typeId = nodeTypeId nodeType
 533
 534                   -------------------------------
 535 insertNodes :: [NodeWrite] -> Cmd err Int64
 536 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 537
 538 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 539 insertNodesR ns = mkCmd $ \conn ->
 540   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 541
 542 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 543 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 544
 545 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 546 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 547 ------------------------------------------------------------------------
 548 -- TODO Hierachy of Nodes
 549 -- post and get same types Node' and update if changes
 550
 551 {- TODO semantic to achieve
 552 post c uid pid [ Node' NodeCorpus "name" "{}" []
 553                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 554                                                                     , Node' NodeDocument "title" "jsonData" []
 555                                                                     ]
 556                                           ]
 557                ]
 558 -}
 559 ------------------------------------------------------------------------
 560
 561 -- TODO
 562 -- currently this function removes the child relation
 563 -- needs a Temporary type between Node' and NodeWriteT
 564 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 565 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 566 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 567
 568
 569 data Node' = Node' { _n_type :: NodeType
 570                    , _n_name :: Text
 571                    , _n_data :: Value
 572                    , _n_children :: [Node']
 573                    } deriving (Show)
 574
 575 mkNodes :: [NodeWrite] -> Cmd err Int64
 576 mkNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 577
 578 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 579 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 580
 581 ------------------------------------------------------------------------
 582
 583 data NewNode = NewNode { _newNodeId :: NodeId
 584                        , _newNodeChildren :: [NodeId] }
 585
 586 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 587
 588 postNode uid pid (Node' nt txt v []) = do
 589   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 590   case pids of
 591     [pid'] -> pure $ NewNode pid' []
 592     _ -> nodeError ManyParents
 593
 594 postNode uid pid (Node' NodeCorpus txt v ns) = do
 595   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 596   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 597   pure $ NewNode pid' pids
 598
 599 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 600   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire 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 -- | TODO mk all others nodes
 614 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 615 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 616 mkNodeWithParent NodeUser Nothing  uId name =
 617   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 618     where
 619       hd = HyperdataUser . Just . pack $ show EN
 620 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 621
 622 ------------------------------------------------------------------------
 623 mkNodeWithParent NodeFolder (Just i) uId name =
 624    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
 625     where
 626       hd = HyperdataFolder . Just . pack $ show EN
 627
 628 mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
 629    insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
 630     where
 631       hd = HyperdataFolder . Just . pack $ show EN
 632
 633 mkNodeWithParent NodeFolderShared (Just i) uId _ =
 634    insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
 635     where
 636       hd = HyperdataFolder . Just . pack $ show EN
 637
 638 mkNodeWithParent NodeFolderPublic (Just i) uId _ =
 639    insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
 640     where
 641       hd = HyperdataFolder . Just . pack $ show EN
 642
 643 mkNodeWithParent NodeTeam (Just i) uId _ =
 644    insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
 645     where
 646       hd = HyperdataFolder . Just . pack $ show EN
 647
 648
 649 ------------------------------------------------------------------------
 650
 651
 652
 653 mkNodeWithParent NodeCorpus (Just i) uId name =
 654    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
 655     where
 656       hd = defaultCorpus
 657
 658 mkNodeWithParent _ _ _ _       = nodeError NotImplYet
 659
 660
 661
 662 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 663 mkRoot uname uId = case uId > 0 of
 664                False -> nodeError NegativeId
 665                True  -> mkNodeWithParent NodeUser Nothing uId uname
 666
 667 -- |
 668 -- CorpusDocument is a corpus made from a set of documents
 669 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 670 data CorpusType = CorpusDocument | CorpusContact
 671
 672 class MkCorpus a
 673   where
 674     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 675
 676 instance MkCorpus HyperdataCorpus
 677   where
 678     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 679
 680
 681 instance MkCorpus HyperdataAnnuaire
 682   where
 683     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 684
 685
 686 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 687 getOrMkList pId uId =
 688   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 689     where
 690       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 691
 692 -- | TODO remove defaultList
 693 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 694 defaultList cId =
 695   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 696
 697 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 698 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 699
 700 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 701 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 702   where
 703     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 704     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 705       where
 706         name = maybe "Board" identity maybeName
 707         dashboard = maybe arbitraryDashboard identity maybeDashboard
 708
 709
 710 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 711 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 712
 713 -- | Default CorpusId Master and ListId Master
 714
 715 pgNodeId :: NodeId -> Column PGInt4
 716 pgNodeId = pgInt4 . id2int
 717
 718 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 719 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)