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 import Opaleye hiding (FromField)
  47 import Opaleye.Internal.QueryArr (Query)
  48 import Prelude hiding (null, id, map, sum)
  49
  50 ------------------------------------------------------------------------
  51
  52 data NodeError = NoListFound
  53                | NoRootFound
  54                | NoCorpusFound
  55                | NoUserFound
  56                | MkNode
  57                | UserNoParent
  58                | HasParent
  59                | ManyParents
  60                | NegativeId
  61                | NotImplYet
  62                | ManyNodeUsers
  63   deriving (Show)
  64
  65 class HasNodeError e where
  66   _NodeError :: Prism' e NodeError
  67
  68 nodeError :: (MonadError e m, HasNodeError e) => NodeError -> m a
  69 nodeError ne = throwError $ _NodeError # ne
  70
  71 catchNodeError :: (MonadError e m, HasNodeError e) => m a -> (NodeError -> m a) -> m a
  72 catchNodeError f g = catchError f (\e -> maybe (throwError e) g (e ^? _NodeError))
  73
  74 ------------------------------------------------------------------------
  75 instance FromField HyperdataAny where
  76     fromField = fromField'
  77
  78 instance FromField HyperdataCorpus
  79   where
  80     fromField = fromField'
  81
  82 instance FromField HyperdataDocument
  83   where
  84     fromField = fromField'
  85
  86 instance FromField HyperdataDocumentV3
  87   where
  88     fromField = fromField'
  89
  90 instance FromField HyperdataUser
  91   where
  92     fromField = fromField'
  93
  94 instance FromField HyperdataList
  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 (NodeId, Text)
 115   where
 116     fromField = fromField'
 117 ------------------------------------------------------------------------
 118 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
 119   where
 120     queryRunnerColumnDefault = fieldQueryRunnerColumn
 121
 122 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
 123   where
 124     queryRunnerColumnDefault = fieldQueryRunnerColumn
 125
 126 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
 127   where
 128     queryRunnerColumnDefault = fieldQueryRunnerColumn
 129
 130 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
 131   where
 132     queryRunnerColumnDefault = fieldQueryRunnerColumn
 133
 134 instance QueryRunnerColumnDefault PGJsonb HyperdataUser
 135   where
 136     queryRunnerColumnDefault = fieldQueryRunnerColumn
 137
 138 instance QueryRunnerColumnDefault PGJsonb HyperdataList
 139   where
 140     queryRunnerColumnDefault = fieldQueryRunnerColumn
 141
 142 instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
 143   where
 144     queryRunnerColumnDefault = fieldQueryRunnerColumn
 145
 146 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 147   where
 148     queryRunnerColumnDefault = fieldQueryRunnerColumn
 149
 150 instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
 151   where
 152     queryRunnerColumnDefault = fieldQueryRunnerColumn
 153
 154 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
 155   where
 156     queryRunnerColumnDefault = fieldQueryRunnerColumn
 157
 158 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
 159   where
 160     queryRunnerColumnDefault = fieldQueryRunnerColumn
 161
 162 instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
 163   where
 164     queryRunnerColumnDefault = fieldQueryRunnerColumn
 165
 166 instance QueryRunnerColumnDefault PGInt4 NodeId
 167   where
 168     queryRunnerColumnDefault = fieldQueryRunnerColumn
 169
 170 instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
 171   where
 172     queryRunnerColumnDefault = fieldQueryRunnerColumn
 173
 174
 175 ------------------------------------------------------------------------
 176 -- WIP
 177 -- TODO Classe HasDefault where
 178 -- default NodeType = Hyperdata
 179 ------------------------------------------------------------------------
 180 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 181 $(makeLensesWith abbreviatedFields ''NodePoly)
 182
 183 $(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
 184 $(makeLensesWith abbreviatedFields ''NodePolySearch)
 185
 186 type NodeWrite = NodePoly (Maybe (Column PGInt4)      )
 187                                  (Column PGInt4)
 188                                  (Column PGInt4)
 189                           (Maybe (Column PGInt4)      )
 190                                  (Column PGText)
 191                           (Maybe (Column PGTimestamptz))
 192                                  (Column PGJsonb)
 193
 194 type NodeRead = NodePoly (Column PGInt4        )
 195                          (Column PGInt4        )
 196                          (Column PGInt4        )
 197                          (Column PGInt4        )
 198                          (Column PGText        )
 199                          (Column PGTimestamptz )
 200                          (Column PGJsonb       )
 201
 202 type NodeReadNull = NodePoly (Column (Nullable PGInt4))
 203                              (Column (Nullable PGInt4))
 204                              (Column (Nullable PGInt4))
 205                              (Column (Nullable PGInt4))
 206                              (Column (Nullable PGText))
 207                              (Column (Nullable PGTimestamptz))
 208                              (Column (Nullable PGJsonb))
 209
 210 nodeTable :: Table NodeWrite NodeRead
 211 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
 212                                       , _node_typename   = required "typename"
 213                                       , _node_userId     = required "user_id"
 214
 215                                       , _node_parentId   = optional "parent_id"
 216                                       , _node_name       = required "name"
 217                                       , _node_date       = optional "date"
 218
 219                                       , _node_hyperdata  = required "hyperdata"
 220                                       }
 221                             )
 222
 223 queryNodeTable :: Query NodeRead
 224 queryNodeTable = queryTable nodeTable
 225
 226 ------------------------------------------------------------------------
 227 -- | Node(Read|Write)Search is slower than Node(Write|Read) use it
 228 -- for full text search only
 229 type NodeSearchWrite =
 230   NodePolySearch
 231     (Maybe  (Column  PGInt4)      )
 232     (Column  PGInt4               )
 233     (Column  PGInt4               )
 234     (Column (Nullable PGInt4)     )
 235     (Column PGText                )
 236     (Maybe  (Column PGTimestamptz))
 237     (Column  PGJsonb              )
 238     (Maybe  (Column PGTSVector)   )
 239
 240 type NodeSearchRead =
 241   NodePolySearch
 242     (Column  PGInt4           )
 243     (Column  PGInt4           )
 244     (Column  PGInt4           )
 245     (Column (Nullable PGInt4 ))
 246     (Column  PGText           )
 247     (Column  PGTimestamptz    )
 248     (Column  PGJsonb          )
 249     (Column  PGTSVector       )
 250
 251 type NodeSearchReadNull =
 252   NodePolySearch
 253     (Column (Nullable PGInt4)       )
 254     (Column (Nullable PGInt4)       )
 255     (Column (Nullable PGInt4)       )
 256     (Column (Nullable PGInt4)       )
 257     (Column (Nullable PGText)       )
 258     (Column (Nullable PGTimestamptz))
 259     (Column (Nullable PGJsonb)      )
 260     (Column (Nullable PGTSVector)   )
 261
 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 [NodeAny]
 290 runGetNodes = runOpaQuery
 291
 292 ------------------------------------------------------------------------
 293 ------------------------------------------------------------------------
 294
 295 -- | order by publication date
 296 -- Favorites (Bool), node_ngrams
 297 selectNodesWith :: ParentId     -> Maybe NodeType
 298                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 299 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 300         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 301   limit' maybeLimit $ offset' maybeOffset
 302                     $ orderBy (asc _node_id)
 303                     $ selectNodesWith' parentId maybeNodeType
 304
 305 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 306 selectNodesWith' parentId maybeNodeType = proc () -> do
 307     node <- (proc () -> do
 308       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 309       restrict -< parentId' .== (pgNodeId parentId)
 310
 311       let typeId' = maybe 0 nodeTypeId maybeNodeType
 312
 313       restrict -< if typeId' > 0
 314                      then typeId   .== (pgInt4 (typeId' :: Int))
 315                      else (pgBool True)
 316       returnA  -< row ) -< ()
 317     returnA -< node
 318
 319 deleteNode :: NodeId -> Cmd err Int
 320 deleteNode n = mkCmd $ \conn ->
 321   fromIntegral <$> runDelete conn nodeTable
 322                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
 323
 324 deleteNodes :: [NodeId] -> Cmd err Int
 325 deleteNodes ns = mkCmd $ \conn ->
 326   fromIntegral <$> runDelete conn nodeTable
 327                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 328
 329 -- TODO: NodeType should match with `a'
 330 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 331              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 332 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 333     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 334
 335 -- TODO: Why is the second parameter ignored?
 336 -- TODO: Why not use getNodesWith?
 337 getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
 338 getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
 339
 340 ------------------------------------------------------------------------
 341 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 342 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 343
 344 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 345 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 346 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 347
 348 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 349 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 350
 351 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 352 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 353
 354 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 355 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 356
 357 ------------------------------------------------------------------------
 358 selectNodesWithParentID :: NodeId -> Query NodeRead
 359 selectNodesWithParentID n = proc () -> do
 360     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 361     restrict -< parent_id .== (pgNodeId n)
 362     returnA -< row
 363
 364 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 365 selectNodesWithType type_id = proc () -> do
 366     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 367     restrict -< tn .== type_id
 368     returnA -< row
 369
 370 type JSONB = QueryRunnerColumnDefault PGJsonb
 371
 372 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 373 getNode nId _ = do
 374     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 375              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 376
 377 getNode' :: NodeId -> Cmd err (Node Value)
 378 getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
 379              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 380
 381
 382 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 383 getNodesWithType = runOpaQuery . selectNodesWithType
 384
 385 ------------------------------------------------------------------------
 386 ------------------------------------------------------------------------
 387 defaultUser :: HyperdataUser
 388 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 389
 390 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 391 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 392   where
 393     name = maybe "User" identity maybeName
 394     user = maybe defaultUser identity maybeHyperdata
 395 ------------------------------------------------------------------------
 396 defaultFolder :: HyperdataFolder
 397 defaultFolder = HyperdataFolder (Just "Markdown Description")
 398
 399 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
 400 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 401   where
 402     name   = maybe "Folder" identity maybeName
 403     folder = maybe defaultFolder identity maybeFolder
 404 ------------------------------------------------------------------------
 405 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 406 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 407   where
 408     name   = maybe "Corpus" identity maybeName
 409     corpus = maybe defaultCorpus identity maybeCorpus
 410                    --------------------------
 411 defaultDocument :: HyperdataDocument
 412 defaultDocument = hyperdataDocument
 413
 414 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 415 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 416   where
 417     name = maybe "Document" identity maybeName
 418     doc  = maybe defaultDocument identity maybeDocument
 419 ------------------------------------------------------------------------
 420 defaultAnnuaire :: HyperdataAnnuaire
 421 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 422
 423 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 424 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 425   where
 426     name     = maybe "Annuaire" identity maybeName
 427     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 428
 429 ------------------------------------------------------------------------
 430 arbitraryList :: HyperdataList
 431 arbitraryList = HyperdataList (Just "Preferences")
 432
 433 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
 434 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 435   where
 436     name = maybe "Listes" identity maybeName
 437     list = maybe arbitraryList identity maybeList
 438
 439                 --------------------
 440
 441 arbitraryListModel :: HyperdataListModel
 442 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 443
 444 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 445 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 446
 447 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 448 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 449   where
 450     name = maybe "List Model" identity maybeName
 451     list = maybe arbitraryListModel identity maybeListModel
 452
 453 ------------------------------------------------------------------------
 454 arbitraryGraph :: HyperdataGraph
 455 arbitraryGraph = HyperdataGraph (Just "Preferences")
 456
 457 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 458 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 459   where
 460     name = maybe "Graph" identity maybeName
 461     graph = maybe arbitraryGraph identity maybeGraph
 462
 463 ------------------------------------------------------------------------
 464 arbitraryPhylo :: HyperdataPhylo
 465 arbitraryPhylo = HyperdataPhylo (Just "Preferences")
 466
 467 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 468 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 469   where
 470     name = maybe "Phylo" identity maybeName
 471     graph = maybe arbitraryPhylo identity maybePhylo
 472
 473
 474 ------------------------------------------------------------------------
 475
 476 arbitraryDashboard :: HyperdataDashboard
 477 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 478
 479 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 480 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 481   where
 482     name = maybe "Dashboard" identity maybeName
 483     dashboard = maybe arbitraryDashboard identity maybeDashboard
 484
 485 ------------------------------------------------------------------------
 486 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 487 node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
 488   where
 489     typeId = nodeTypeId nodeType
 490
 491                   -------------------------------
 492 insertNodes :: [NodeWrite] -> Cmd err Int64
 493 insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 494
 495 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 496 insertNodesR ns = mkCmd $ \conn ->
 497   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 498
 499 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 500 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 501
 502 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 503 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 504 ------------------------------------------------------------------------
 505 -- TODO Hierachy of Nodes
 506 -- post and get same types Node' and update if changes
 507
 508 {- TODO semantic to achieve
 509 post c uid pid [ Node' NodeCorpus "name" "{}" []
 510                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 511                                                                     , Node' NodeDocument "title" "jsonData" []
 512                                                                     ]
 513                                           ]
 514                ]
 515 -}
 516 ------------------------------------------------------------------------
 517
 518 -- TODO
 519 -- currently this function removes the child relation
 520 -- needs a Temporary type between Node' and NodeWriteT
 521 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 522 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 523 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 524
 525
 526 data Node' = Node' { _n_type :: NodeType
 527                    , _n_name :: Text
 528                    , _n_data :: Value
 529                    , _n_children :: [Node']
 530                    } deriving (Show)
 531
 532 mkNode :: [NodeWrite] -> Cmd err Int64
 533 mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 534
 535 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 536 mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 537
 538 ------------------------------------------------------------------------
 539
 540 data NewNode = NewNode { _newNodeId :: NodeId
 541                        , _newNodeChildren :: [NodeId] }
 542
 543 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 544 postNode uid pid (Node' nt txt v []) = do
 545   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 546   case pids of
 547     [pid'] -> pure $ NewNode pid' []
 548     _ -> nodeError ManyParents
 549
 550 postNode uid pid (Node' NodeCorpus txt v ns) = do
 551   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 552   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 553   pure $ NewNode pid' pids
 554
 555 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 556   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 557   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 558   pure $ NewNode pid' pids
 559 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 560
 561
 562 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 563 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 564 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 565 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 566
 567
 568 type Name = Text
 569
 570 -- | TODO mk all others nodes
 571 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 572 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 573 mkNodeWithParent NodeUser Nothing  uId name =
 574   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
 575     where
 576       hd = HyperdataUser . Just . pack $ show EN
 577 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
 578 mkNodeWithParent _ _ _ _ = nodeError NotImplYet
 579
 580
 581 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 582 mkRoot uname uId = case uId > 0 of
 583                False -> nodeError NegativeId
 584                True  -> mkNodeWithParent NodeUser Nothing uId uname
 585
 586 -- |
 587 -- CorpusDocument is a corpus made from a set of documents
 588 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 589 data CorpusType = CorpusDocument | CorpusContact
 590
 591 class MkCorpus a
 592   where
 593     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 594
 595 instance MkCorpus HyperdataCorpus
 596   where
 597     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 598
 599
 600 instance MkCorpus HyperdataAnnuaire
 601   where
 602     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 603
 604
 605 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 606 getOrMkList pId uId =
 607   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 608     where
 609       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkList pId uId
 610
 611 -- | TODO remove defaultList
 612 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 613 defaultList cId =
 614   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 615
 616 mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 617 mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
 618
 619 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 620 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 621
 622 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 623 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 624
 625 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 626 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 627
 628 -- | Default CorpusId Master and ListId Master
 629
 630 pgNodeId :: NodeId -> Column PGInt4
 631 pgNodeId = pgInt4 . id2int