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