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
  26 module Gargantext.Database.Schema.Node where
  27
  28 import Control.Arrow (returnA)
  29 import Control.Lens (Prism', set, view, (#), (^?))
  30 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  31 import Control.Monad.Error.Class (MonadError(..))
  32 import Data.Aeson
  33 import Data.Maybe (Maybe(..), fromMaybe)
  34 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  35 import Data.Text (Text, pack)
  36 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  37 import GHC.Int (Int64)
  38 import Gargantext.Core (Lang(..))
  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)
  44 import Gargantext.Database.Utils
  45 import Gargantext.Prelude hiding (sum, head)
  46
  47 import Opaleye hiding (FromField)
  48 import Opaleye.Internal.QueryArr (Query)
  49 import Prelude hiding (null, id, map, sum)
  50
  51 ------------------------------------------------------------------------
  52
  53 data NodeError = NoListFound
  54                | NoRootFound
  55                | NoCorpusFound
  56                | NoUserFound
  57                | MkNode
  58                | UserNoParent
  59                | HasParent
  60                | ManyParents
  61                | NegativeId
  62                | NotImplYet
  63                | ManyNodeUsers
  64   deriving (Show)
  65
  66 class HasNodeError e where
  67   _NodeError :: Prism' e NodeError
  68
  69 nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
  70 nodeError ne = throwError $ _NodeError # ne
  71
  72 catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
  73 catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
  74
  75 ------------------------------------------------------------------------
  76 instance FromField HyperdataAny where
  77     fromField = fromField'
  78
  79 instance FromField HyperdataCorpus
  80   where
  81     fromField = fromField'
  82
  83 instance FromField HyperdataDocument
  84   where
  85     fromField = fromField'
  86
  87 instance FromField HyperdataDocumentV3
  88   where
  89     fromField = fromField'
  90
  91 instance FromField HyperdataUser
  92   where
  93     fromField = fromField'
  94
  95 instance FromField HyperdataList
  96   where
  97     fromField = fromField'
  98
  99 instance FromField HyperdataListModel
 100   where
 101     fromField = fromField'
 102
 103 instance FromField HyperdataGraph
 104   where
 105     fromField = fromField'
 106
 107 instance FromField HyperdataPhylo
 108   where
 109     fromField = fromField'
 110
 111 instance FromField HyperdataAnnuaire
 112   where
 113     fromField = fromField'
 114
 115 instance FromField (NodeId, Text)
 116   where
 117     fromField = fromField'
 118 ------------------------------------------------------------------------
 119 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
 120   where
 121     queryRunnerColumnDefault = fieldQueryRunnerColumn
 122
 123 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
 124   where
 125     queryRunnerColumnDefault = fieldQueryRunnerColumn
 126
 127 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
 128   where
 129     queryRunnerColumnDefault = fieldQueryRunnerColumn
 130
 131 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
 132   where
 133     queryRunnerColumnDefault = fieldQueryRunnerColumn
 134
 135 instance QueryRunnerColumnDefault PGJsonb HyperdataUser
 136   where
 137     queryRunnerColumnDefault = fieldQueryRunnerColumn
 138
 139 instance QueryRunnerColumnDefault PGJsonb HyperdataList
 140   where
 141     queryRunnerColumnDefault = fieldQueryRunnerColumn
 142
 143 instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
 144   where
 145     queryRunnerColumnDefault = fieldQueryRunnerColumn
 146
 147 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 148   where
 149     queryRunnerColumnDefault = fieldQueryRunnerColumn
 150
 151 instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
 152   where
 153     queryRunnerColumnDefault = fieldQueryRunnerColumn
 154
 155 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
 156   where
 157     queryRunnerColumnDefault = fieldQueryRunnerColumn
 158
 159 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
 160   where
 161     queryRunnerColumnDefault = fieldQueryRunnerColumn
 162
 163 instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
 164   where
 165     queryRunnerColumnDefault = fieldQueryRunnerColumn
 166
 167 instance QueryRunnerColumnDefault PGInt4 NodeId
 168   where
 169     queryRunnerColumnDefault = fieldQueryRunnerColumn
 170
 171 instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
 172   where
 173     queryRunnerColumnDefault = fieldQueryRunnerColumn
 174
 175
 176 ------------------------------------------------------------------------
 177 -- WIP
 178 -- TODO Classe HasDefault where
 179 -- default NodeType = Hyperdata
 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 --{-
 264 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 265 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
 266                                       , _ns_typename   = required "typename"
 267                                       , _ns_userId     = required "user_id"
 268
 269                                       , _ns_parentId   = required "parent_id"
 270                                       , _ns_name       = required "name"
 271                                       , _ns_date       = optional "date"
 272
 273                                       , _ns_hyperdata  = required "hyperdata"
 274                                       , _ns_search     = optional "search"
 275                                       }
 276                             )
 277 --}
 278
 279 queryNodeSearchTable :: Query NodeSearchRead
 280 queryNodeSearchTable = queryTable nodeTableSearch
 281
 282 selectNode :: Column PGInt4 -> Query NodeRead
 283 selectNode id = proc () -> do
 284     row <- queryNodeTable -< ()
 285     restrict -< _node_id row .== id
 286     returnA -< row
 287
 288
 289
 290 runGetNodes :: Query NodeRead -> Cmd err [NodeAny]
 291 runGetNodes = runOpaQuery
 292
 293 ------------------------------------------------------------------------
 294 ------------------------------------------------------------------------
 295
 296 -- | order by publication date
 297 -- Favorites (Bool), node_ngrams
 298 selectNodesWith :: ParentId     -> Maybe NodeType
 299                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 300 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 301         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 302   limit' maybeLimit $ offset' maybeOffset
 303                     $ orderBy (asc _node_id)
 304                     $ selectNodesWith' parentId maybeNodeType
 305
 306 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 307 selectNodesWith' parentId maybeNodeType = proc () -> do
 308     node <- (proc () -> do
 309       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 310       restrict -< parentId' .== (pgNodeId parentId)
 311
 312       let typeId' = maybe 0 nodeTypeId maybeNodeType
 313
 314       restrict -< if typeId' > 0
 315                      then typeId   .== (pgInt4 (typeId' :: Int))
 316                      else (pgBool True)
 317       returnA  -< row ) -< ()
 318     returnA -< node
 319
 320 deleteNode :: NodeId -> Cmd err Int
 321 deleteNode n = mkCmd $ \conn ->
 322   fromIntegral <$> runDelete conn nodeTable
 323                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 324
 325 deleteNodes :: [NodeId] -> Cmd err Int
 326 deleteNodes ns = mkCmd $ \conn ->
 327   fromIntegral <$> runDelete conn nodeTable
 328                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 329
 330 -- TODO: NodeType should match with `a'
 331 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 332              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 333 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 334     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 335
 336 -- TODO: Why is the second parameter ignored?
 337 -- TODO: Why not use getNodesWith?
 338 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
 339 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 340
 341 ------------------------------------------------------------------------
 342 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 343 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 344
 345 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 346 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 347 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 348
 349 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 350 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 351
 352 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 353 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 354
 355 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 356 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 357
 358 ------------------------------------------------------------------------
 359 selectNodesWithParentID :: NodeId -> Query NodeRead
 360 selectNodesWithParentID n = proc () -> do
 361     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 362     restrict -< parent_id .== (pgNodeId n)
 363     returnA -< row
 364
 365 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 366 selectNodesWithType type_id = proc () -> do
 367     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 368     restrict -< tn .== type_id
 369     returnA -< row
 370
 371 type JSONB = QueryRunnerColumnDefault PGJsonb
 372
 373 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 374 getNode nId _ = do
 375     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 376              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 377
 378 getNodePhylo :: NodeId -> Cmd err (NodePhylo)
 379 getNodePhylo nId = do
 380     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 381              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 382
 383
 384
 385 getNode' :: NodeId -> Cmd err (Node Value)
 386 getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 387              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 388
 389
 390 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 391 getNodesWithType = runOpaQuery . selectNodesWithType
 392
 393 ------------------------------------------------------------------------
 394 ------------------------------------------------------------------------
 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 arbitraryTexts :: HyperdataTexts
 440 arbitraryTexts = HyperdataTexts (Just "Preferences")
 441
 442 nodeTextsW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 443 nodeTextsW maybeName maybeList pId = node NodeList name list (Just pId)
 444   where
 445     name = maybe "Texts" identity maybeName
 446     list = maybe arbitraryList identity maybeList
 447
 448 ------------------------------------------------------------------------
 449 arbitraryList :: HyperdataList
 450 arbitraryList = HyperdataList (Just "Preferences")
 451
 452 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 453 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 454   where
 455     name = maybe "Lists" identity maybeName
 456     list = maybe arbitraryList identity maybeList
 457
 458                 --------------------
 459
 460 arbitraryListModel :: HyperdataListModel
 461 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 462
 463 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 464 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 465
 466 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 467 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 468   where
 469     name = maybe "List Model" identity maybeName
 470     list = maybe arbitraryListModel identity maybeListModel
 471
 472 ------------------------------------------------------------------------
 473 arbitraryGraph :: HyperdataGraph
 474 arbitraryGraph = HyperdataGraph (Just "Preferences")
 475
 476 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 477 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 478   where
 479     name = maybe "Graph" identity maybeName
 480     graph = maybe arbitraryGraph identity maybeGraph
 481
 482 ------------------------------------------------------------------------
 483 arbitraryPhylo :: HyperdataPhylo
 484 arbitraryPhylo = HyperdataPhylo Nothing Nothing
 485
 486 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 487 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 488   where
 489     name = maybe "Phylo" identity maybeName
 490     graph = maybe arbitraryPhylo identity maybePhylo
 491
 492
 493 ------------------------------------------------------------------------
 494
 495 arbitraryDashboard :: HyperdataDashboard
 496 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 497
 498 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 499 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 500   where
 501     name = maybe "Dashboard" identity maybeName
 502     dashboard = maybe arbitraryDashboard identity maybeDashboard
 503
 504 ------------------------------------------------------------------------
 505 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 506 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 507   where
 508     typeId = nodeTypeId nodeType
 509
 510                   -------------------------------
 511 insertNodes :: [NodeWrite] -> Cmd err Int64
 512 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 513
 514 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 515 insertNodesR ns = mkCmd $ \conn ->
 516   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 517
 518 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 519 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 520
 521 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 522 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 523 ------------------------------------------------------------------------
 524 -- TODO Hierachy of Nodes
 525 -- post and get same types Node' and update if changes
 526
 527 {- TODO semantic to achieve
 528 post c uid pid [ Node' NodeCorpus "name" "{}" []
 529                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 530                                                                     , Node' NodeDocument "title" "jsonData" []
 531                                                                     ]
 532                                           ]
 533                ]
 534 -}
 535 ------------------------------------------------------------------------
 536
 537 -- TODO
 538 -- currently this function removes the child relation
 539 -- needs a Temporary type between Node' and NodeWriteT
 540 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 541 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 542 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 543
 544
 545 data Node' = Node' { _n_type :: NodeType
 546                    , _n_name :: Text
 547                    , _n_data :: Value
 548                    , _n_children :: [Node']
 549                    } deriving (Show)
 550
 551 mkNode :: [NodeWrite] -> Cmd err Int64
 552 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 553
 554 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 555 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 556
 557 ------------------------------------------------------------------------
 558
 559 data NewNode = NewNode { _newNodeId :: NodeId
 560                        , _newNodeChildren :: [NodeId] }
 561
 562 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 563 postNode uid pid (Node' nt txt v []) = do
 564   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 565   case pids of
 566     [pid'] -> pure $ NewNode pid' []
 567     _ -> nodeError ManyParents
 568
 569 postNode uid pid (Node' NodeCorpus txt v ns) = do
 570   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 571   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 572   pure $ NewNode pid' pids
 573
 574 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 575   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 576   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 577   pure $ NewNode pid' pids
 578 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 579
 580
 581 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 582 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 583 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 584 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 585
 586
 587 type Name = Text
 588
 589 -- | TODO mk all others nodes
 590 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 591 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 592 mkNodeWithParent NodeUser Nothing  uId name =
 593   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 594     where
 595       hd = HyperdataUser . Just . pack $ show EN
 596 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 597 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
 598
 599
 600 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 601 mkRoot uname uId = case uId > 0 of
 602                False -> nodeError NegativeId
 603                True  -> mkNodeWithParent NodeUser Nothing uId uname
 604
 605 -- |
 606 -- CorpusDocument is a corpus made from a set of documents
 607 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 608 data CorpusType = CorpusDocument | CorpusContact
 609
 610 class MkCorpus a
 611   where
 612     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 613
 614 instance MkCorpus HyperdataCorpus
 615   where
 616     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 617
 618
 619 instance MkCorpus HyperdataAnnuaire
 620   where
 621     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 622
 623
 624 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 625 getOrMkList pId uId =
 626   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 627     where
 628       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
 629
 630 -- | TODO remove defaultList
 631 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 632 defaultList cId =
 633   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 634
 635 mkTexts :: ParentId -> UserId -> Cmd err [NodeId]
 636 mkTexts p u = insertNodesR [nodeTextsW Nothing Nothing p u]
 637
 638 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 639 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 640
 641 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 642 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 643
 644 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 645 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 646
 647 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 648 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 649
 650 -- | Default CorpusId Master and ListId Master
 651
 652 pgNodeId :: NodeId -> Column PGInt4
 653 pgNodeId = pgInt4 . id2int