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 :: HyperdataCorpus
 405 defaultFolder = defaultCorpus
 406
 407 nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> 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 =
 534   Node Nothing
 535        (pgInt4 typeId)
 536        (pgInt4 userId)
 537        (pgNodeId <$> parentId)
 538        (pgStrictText name)
 539        Nothing
 540        (pgJSONB $ cs $ encode hyperData)
 541     where
 542       typeId = nodeTypeId nodeType
 543
 544                   -------------------------------
 545 insertNodes :: [NodeWrite] -> Cmd err Int64
 546 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 547
 548 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 549 insertNodesR ns = mkCmd $ \conn ->
 550   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 551
 552 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 553 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 554
 555 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 556 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 557 ------------------------------------------------------------------------
 558 -- TODO Hierachy of Nodes
 559 -- post and get same types Node' and update if changes
 560
 561 {- TODO semantic to achieve
 562 post c uid pid [ Node' NodeCorpus "name" "{}" []
 563                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 564                                                                     , Node' NodeDocument "title" "jsonData" []
 565                                                                     ]
 566                                           ]
 567                ]
 568 -}
 569 ------------------------------------------------------------------------
 570
 571 -- TODO
 572 -- currently this function removes the child relation
 573 -- needs a Temporary type between Node' and NodeWriteT
 574 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 575 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 576 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 577
 578
 579 data Node' = Node' { _n_type :: NodeType
 580                    , _n_name :: Text
 581                    , _n_data :: Value
 582                    , _n_children :: [Node']
 583                    } deriving (Show)
 584
 585 mkNodes :: [NodeWrite] -> Cmd err Int64
 586 mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 587
 588 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 589 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 590
 591 ------------------------------------------------------------------------
 592
 593 data NewNode = NewNode { _newNodeId :: NodeId
 594                        , _newNodeChildren :: [NodeId] }
 595
 596 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 597
 598 postNode uid pid (Node' nt txt v []) = do
 599   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 600   case pids of
 601     [pid'] -> pure $ NewNode pid' []
 602     _ -> nodeError ManyParents
 603
 604 postNode uid pid (Node' NodeCorpus txt v ns) = do
 605   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 606   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 607   pure $ NewNode pid' pids
 608
 609 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 610   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 611   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 612   pure $ NewNode pid' pids
 613
 614 postNode uid pid (Node' NodeDashboard txt v ns) = do
 615   NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
 616   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 617   pure $ NewNode pid' pids
 618
 619 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 620
 621
 622 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 623 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 624 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 625 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 626
 627
 628 -- =================================================================== --
 629 ------------------------------------------------------------------------
 630 -- | TODO mk all others nodes
 631 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 632 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 633
 634 ------------------------------------------------------------------------
 635 mkNodeWithParent NodeUser Nothing  uId name =
 636   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 637     where
 638       hd = HyperdataUser . Just . pack $ show EN
 639 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 640 ------------------------------------------------------------------------
 641 mkNodeWithParent NodeFolder (Just i) uId name =
 642    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
 643     where
 644       hd = defaultFolder
 645
 646 mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
 647    insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
 648     where
 649       hd = defaultFolder
 650
 651 mkNodeWithParent NodeFolderShared (Just i) uId _ =
 652    insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
 653     where
 654       hd = defaultFolder
 655
 656 mkNodeWithParent NodeFolderPublic (Just i) uId _ =
 657    insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
 658     where
 659       hd = defaultFolder
 660
 661 mkNodeWithParent NodeTeam (Just i) uId _ =
 662    insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
 663     where
 664       hd = defaultFolder
 665 ------------------------------------------------------------------------
 666 mkNodeWithParent NodeCorpus (Just i) uId name =
 667    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
 668     where
 669       hd = defaultCorpus
 670
 671 mkNodeWithParent NodeAnnuaire (Just i) uId name =
 672    insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
 673     where
 674       hd = defaultAnnuaire
 675
 676 mkNodeWithParent _ _ _ _       = nodeError NotImplYet
 677 ------------------------------------------------------------------------
 678 -- =================================================================== --
 679
 680
 681
 682 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 683 mkRoot uname uId = case uId > 0 of
 684                False -> nodeError NegativeId
 685                True  -> do
 686                  rs <- mkNodeWithParent NodeUser Nothing uId uname
 687                  _ <- case rs of
 688                    [r] -> do
 689                      _ <- mkNodeWithParent NodeFolderPrivate (Just r) uId uname
 690                      _ <- mkNodeWithParent NodeFolderShared  (Just r) uId uname
 691                      _ <- mkNodeWithParent NodeFolderPublic  (Just r) uId uname
 692                      pure rs
 693                    _   -> pure rs
 694                  pure rs
 695
 696 -- |
 697 -- CorpusDocument is a corpus made from a set of documents
 698 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 699 data CorpusType = CorpusDocument | CorpusContact
 700
 701 class MkCorpus a
 702   where
 703     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 704
 705 instance MkCorpus HyperdataCorpus
 706   where
 707     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 708
 709
 710 instance MkCorpus HyperdataAnnuaire
 711   where
 712     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 713
 714
 715 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 716 getOrMkList pId uId =
 717   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 718     where
 719       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 720
 721 -- | TODO remove defaultList
 722 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 723 defaultList cId =
 724   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 725
 726 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 727 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 728
 729 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 730 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 731   where
 732     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 733     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 734       where
 735         name = maybe "Board" identity maybeName
 736         dashboard = maybe arbitraryDashboard identity maybeDashboard
 737
 738
 739 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 740 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 741
 742 -- | Default CorpusId Master and ListId Master
 743
 744 pgNodeId :: NodeId -> Column PGInt4
 745 pgNodeId = pgInt4 . id2int
 746
 747 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 748 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 749