src/Gargantext/Database/Schema/Node.hs

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