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 TemplateHaskell        #-}
  24
  25 module Gargantext.Database.Schema.Node where
  26
  27 import Control.Arrow (returnA)
  28 import Control.Lens (set)
  29 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  30 import Data.Aeson
  31 import Data.ByteString (ByteString)
  32 import Data.Maybe (Maybe(..), fromMaybe)
  33 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  34 import Data.Text (Text, pack)
  35 import Data.Time (UTCTime)
  36 import Database.PostgreSQL.Simple (Connection)
  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.Core.Types.Main (UserId)
  43 import Gargantext.Database.Config (nodeTypeId)
  44 import Gargantext.Database.Queries.Filter (limit', offset')
  45 import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
  46 import Gargantext.Database.Utils
  47 import Gargantext.Prelude hiding (sum, head)
  48 import Opaleye hiding (FromField)
  49 import Opaleye.Internal.QueryArr (Query)
  50 import Prelude hiding (null, id, map, sum)
  51 import qualified Data.ByteString      as DB
  52 import qualified Data.ByteString.Lazy as DBL
  53 import qualified Data.Profunctor.Product as PP
  54
  55 ------------------------------------------------------------------------
  56 instance FromField HyperdataAny
  57   where
  58     fromField = fromField'
  59
  60 instance FromField HyperdataCorpus
  61   where
  62     fromField = fromField'
  63
  64 instance FromField HyperdataDocument
  65   where
  66     fromField = fromField'
  67
  68 instance FromField HyperdataDocumentV3
  69   where
  70     fromField = fromField'
  71
  72 instance FromField HyperdataUser
  73   where
  74     fromField = fromField'
  75
  76 instance FromField HyperdataList
  77   where
  78     fromField = fromField'
  79
  80 instance FromField HyperdataGraph
  81   where
  82     fromField = fromField'
  83
  84 instance FromField HyperdataAnnuaire
  85   where
  86     fromField = fromField'
  87 ------------------------------------------------------------------------
  88 instance QueryRunnerColumnDefault PGJsonb HyperdataAny
  89   where
  90     queryRunnerColumnDefault = fieldQueryRunnerColumn
  91
  92 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument
  93   where
  94     queryRunnerColumnDefault = fieldQueryRunnerColumn
  95
  96 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
  97   where
  98     queryRunnerColumnDefault = fieldQueryRunnerColumn
  99
 100 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
 101   where
 102     queryRunnerColumnDefault = fieldQueryRunnerColumn
 103
 104 instance QueryRunnerColumnDefault PGJsonb HyperdataUser
 105   where
 106     queryRunnerColumnDefault = fieldQueryRunnerColumn
 107
 108 instance QueryRunnerColumnDefault PGJsonb HyperdataList
 109   where
 110     queryRunnerColumnDefault = fieldQueryRunnerColumn
 111
 112 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 113   where
 114     queryRunnerColumnDefault = fieldQueryRunnerColumn
 115
 116 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
 117   where
 118     queryRunnerColumnDefault = fieldQueryRunnerColumn
 119
 120 instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
 121   where
 122     queryRunnerColumnDefault = fieldQueryRunnerColumn
 123
 124
 125 ------------------------------------------------------------------------
 126
 127 -- WIP
 128 -- TODO Classe HasDefault where
 129 -- default NodeType = Hyperdata
 130 ------------------------------------------------------------------------
 131 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 132 $(makeLensesWith abbreviatedFields ''NodePoly)
 133 $(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
 134 $(makeLensesWith abbreviatedFields ''NodePolySearch)
 135
 136 type NodeWrite = NodePoly  (Maybe (Column  PGInt4              ))
 137                                   (Column  PGInt4               )
 138                                   (Column  PGInt4               )
 139                                   (Column (Nullable PGInt4     ))
 140                                   (Column (PGText              ))
 141                                   (Maybe  (Column PGTimestamptz))
 142                                   (Column  PGJsonb              )
 143
 144 type NodeRead = NodePoly  (Column  PGInt4           )
 145                           (Column  PGInt4           )
 146                           (Column  PGInt4           )
 147                           (Column (Nullable PGInt4 ))
 148                           (Column (PGText          ))
 149                           (Column PGTimestamptz     )
 150                           (Column PGJsonb)
 151
 152
 153 type NodeReadNull = NodePoly  (Column  (Nullable PGInt4           ))
 154                               (Column  (Nullable PGInt4           ))
 155                               (Column  (Nullable PGInt4           ))
 156                               (Column (Nullable PGInt4 ))
 157                               (Column (Nullable PGText          ))
 158                               (Column (Nullable PGTimestamptz     ))
 159                               (Column (Nullable PGJsonb))
 160
 161 nodeTable :: Table NodeWrite NodeRead
 162 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
 163                                       , _node_typename   = required "typename"
 164                                       , _node_userId     = required "user_id"
 165
 166                                       , _node_parentId   = required "parent_id"
 167                                       , _node_name       = required "name"
 168                                       , _node_date       = optional "date"
 169
 170                                       , _node_hyperdata  = required "hyperdata"
 171                                       }
 172                             )
 173
 174 queryNodeTable :: Query NodeRead
 175 queryNodeTable = queryTable nodeTable
 176
 177 -- | TODO remove below
 178 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 179
 180 --{-
 181 nodeTable' :: Table (Maybe (Column PGInt4)
 182                     ,       Column PGInt4
 183                     ,       Column PGInt4
 184                     ,Maybe (Column PGInt4)
 185                     ,       Column PGText
 186                     ,Maybe (Column PGTimestamptz)
 187                     ,       Column PGJsonb
 188                     )
 189                     ((Column PGInt4)
 190                     ,       Column PGInt4
 191                     ,       Column PGInt4
 192                     ,       Column PGInt4
 193                     ,       Column PGText
 194                     ,(Column PGTimestamptz)
 195                     ,       Column PGJsonb
 196                     )
 197
 198 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
 199                                , required "typename"
 200                                , required "user_id"
 201
 202                                , optional "parent_id"
 203                                , required "name"
 204                                , optional "date"
 205
 206                                , required "hyperdata"
 207                                )
 208                             )
 209 --}
 210 ------------------------------------------------------------------------
 211 -- | Node(Read|Write)Search is slower than Node(Write|Read) use it
 212 -- for full text search only
 213
 214 type NodeSearchWrite = NodePolySearch  (Maybe (Column  PGInt4              ))
 215                                   (Column  PGInt4               )
 216                                   (Column  PGInt4               )
 217                                   (Column (Nullable PGInt4     ))
 218                                   (Column (PGText              ))
 219                                   (Maybe  (Column PGTimestamptz))
 220                                   (Column  PGJsonb              )
 221                                   (Maybe (Column PGTSVector))
 222
 223 type NodeSearchRead = NodePolySearch  (Column  PGInt4           )
 224                           (Column  PGInt4           )
 225                           (Column  PGInt4           )
 226                           (Column (Nullable PGInt4 ))
 227                           (Column (PGText          ))
 228                           (Column PGTimestamptz     )
 229                           (Column PGJsonb)
 230                           (Column PGTSVector)
 231
 232
 233 type NodeSearchReadNull = NodePolySearch  (Column  (Nullable PGInt4           ))
 234                               (Column  (Nullable PGInt4           ))
 235                               (Column  (Nullable PGInt4           ))
 236                               (Column (Nullable PGInt4 ))
 237                               (Column (Nullable PGText          ))
 238                               (Column (Nullable PGTimestamptz     ))
 239                               (Column (Nullable PGJsonb))
 240                               (Column (Nullable PGTSVector))
 241
 242
 243 --{-
 244 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 245 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
 246                                       , _ns_typename   = required "typename"
 247                                       , _ns_userId     = required "user_id"
 248
 249                                       , _ns_parentId   = required "parent_id"
 250                                       , _ns_name       = required "name"
 251                                       , _ns_date       = optional "date"
 252
 253                                       , _ns_hyperdata  = required "hyperdata"
 254                                       , _ns_search     = optional "search"
 255                                       }
 256                             )
 257 --}
 258
 259 queryNodeSearchTable :: Query NodeSearchRead
 260 queryNodeSearchTable = queryTable nodeTableSearch
 261
 262
 263 selectNode :: Column PGInt4 -> Query NodeRead
 264 selectNode id = proc () -> do
 265     row <- queryNodeTable -< ()
 266     restrict -< _node_id row .== id
 267     returnA -< row
 268
 269
 270 runGetNodes :: Query NodeRead -> Cmd [NodeAny]
 271 runGetNodes q = mkCmd $ \conn -> runQuery conn q
 272
 273 ------------------------------------------------------------------------
 274 ------------------------------------------------------------------------
 275
 276 -- | order by publication date
 277 -- Favorites (Bool), node_ngrams
 278 selectNodesWith :: ParentId     -> Maybe NodeType
 279                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 280 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 281         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 282   limit' maybeLimit $ offset' maybeOffset
 283                     $ orderBy (asc _node_id)
 284                     $ selectNodesWith' parentId maybeNodeType
 285
 286 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 287 selectNodesWith' parentId maybeNodeType = proc () -> do
 288     node <- (proc () -> do
 289       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 290       restrict -< parentId' .== (toNullable $ pgInt4 parentId)
 291
 292       let typeId' = maybe 0 nodeTypeId maybeNodeType
 293
 294       restrict -< if typeId' > 0
 295                      then typeId   .== (pgInt4 (typeId' :: Int))
 296                      else (pgBool True)
 297       returnA  -< row ) -< ()
 298     returnA -< node
 299
 300
 301
 302 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
 303 -- deleteNode :: Int -> Cmd' Int
 304
 305 deleteNode :: Int -> Cmd Int
 306 deleteNode n = mkCmd $ \conn ->
 307   fromIntegral <$> runDelete conn nodeTable
 308                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 309
 310 deleteNodes :: [Int] -> Cmd Int
 311 deleteNodes ns = mkCmd $ \conn ->
 312   fromIntegral <$> runDelete conn nodeTable
 313                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 314
 315
 316 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
 317              -> Maybe Offset -> Maybe Limit -> IO [Node a]
 318 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
 319     runQuery conn $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 320
 321
 322 -- NP check type
 323 getNodesWithParentId :: Int
 324                      -> Maybe Text -> Connection -> IO [NodeAny]
 325 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 326
 327 getNodesWithParentId' :: Int
 328                      -> Maybe Text -> Connection -> IO [NodeAny]
 329 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 330
 331
 332 ------------------------------------------------------------------------
 333 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 334 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 335
 336 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 337 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 338
 339 getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
 340 getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
 341
 342 getCorporaWithParentId :: Connection -> Int -> IO [Node HyperdataCorpus]
 343 getCorporaWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeCorpus)
 344
 345 getCorporaWithParentId' :: Int -> Cmd [Node HyperdataCorpus]
 346 getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n (Just NodeCorpus)
 347
 348
 349 ------------------------------------------------------------------------
 350 selectNodesWithParentID :: Int -> Query NodeRead
 351 selectNodesWithParentID n = proc () -> do
 352     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 353     restrict -< if n > 0
 354       then parent_id .== (toNullable $ pgInt4 n)
 355       else isNull parent_id
 356     returnA -< row
 357
 358 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 359 selectNodesWithType type_id = proc () -> do
 360     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 361     restrict -< tn .== type_id
 362     returnA -< row
 363
 364 type JSONB = QueryRunnerColumnDefault PGJsonb
 365
 366 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
 367 getNode conn id _ = do
 368     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 369
 370 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 371 getNodesWithType conn type_id = do
 372     runQuery conn $ selectNodesWithType type_id
 373
 374 ------------------------------------------------------------------------
 375
 376 ------------------------------------------------------------------------
 377 defaultUser :: HyperdataUser
 378 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 379
 380 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
 381 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 382   where
 383     name = maybe "User" identity maybeName
 384     user = maybe defaultUser identity maybeHyperdata
 385 ------------------------------------------------------------------------
 386 defaultFolder :: HyperdataFolder
 387 defaultFolder = HyperdataFolder (Just "Markdown Description")
 388
 389 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
 390 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 391   where
 392     name   = maybe "Folder" identity maybeName
 393     folder = maybe defaultFolder identity maybeFolder
 394 ------------------------------------------------------------------------
 395 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
 396 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 397   where
 398     name   = maybe "Corpus" identity maybeName
 399     corpus = maybe defaultCorpus identity maybeCorpus
 400                    --------------------------
 401 defaultDocument :: HyperdataDocument
 402 defaultDocument = hyperdataDocument
 403
 404 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
 405 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 406   where
 407     name = maybe "Document" identity maybeName
 408     doc  = maybe defaultDocument identity maybeDocument
 409 ------------------------------------------------------------------------
 410 defaultAnnuaire :: HyperdataAnnuaire
 411 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 412
 413 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
 414 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 415   where
 416     name     = maybe "Annuaire" identity maybeName
 417     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 418                    --------------------------
 419
 420 ------------------------------------------------------------------------
 421 arbitraryList :: HyperdataList
 422 arbitraryList = HyperdataList (Just "Preferences")
 423
 424 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite'
 425 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 426   where
 427     name = maybe "Listes" identity maybeName
 428     list = maybe arbitraryList identity maybeList
 429
 430 ------------------------------------------------------------------------
 431 arbitraryGraph :: HyperdataGraph
 432 arbitraryGraph = HyperdataGraph (Just "Preferences")
 433
 434 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite'
 435 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 436   where
 437     name = maybe "Graph" identity maybeName
 438     graph = maybe arbitraryGraph identity maybeGraph
 439
 440 ------------------------------------------------------------------------
 441
 442 arbitraryDashboard :: HyperdataDashboard
 443 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 444
 445 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite'
 446 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 447   where
 448     name = maybe "Dashboard" identity maybeName
 449     dashboard = maybe arbitraryDashboard identity maybeDashboard
 450
 451
 452
 453 ------------------------------------------------------------------------
 454 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
 455 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
 456   where
 457     typeId = nodeTypeId nodeType
 458     byteData = DB.pack . DBL.unpack $ encode hyperData
 459
 460                   -------------------------------
 461 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
 462               NodePoly (maybe1 Int) Int  Int
 463                        (maybe2 Int) Text (maybe3 UTCTime)
 464                        ByteString
 465                     -> ( maybe1 (Column PGInt4), Column PGInt4, Column PGInt4
 466                        , maybe2 (Column PGInt4), Column PGText, maybe3 (Column PGTimestamptz)
 467                      , Column PGJsonb)
 468 node2row (Node id tn ud pid nm dt hp) = ((pgInt4       <$> id)
 469                                            ,(pgInt4           tn)
 470                                            ,(pgInt4           ud)
 471
 472                                            ,(pgInt4       <$> pid)
 473                                            ,(pgStrictText     nm)
 474                                            ,(pgUTCTime    <$> dt)
 475
 476                                            ,(pgStrictJSONB    hp)
 477                                            )
 478 ------------------------------------------------------------------------
 479 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
 480 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
 481
 482 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
 483 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
 484
 485 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
 486 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
 487                        -------------------------
 488 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
 489 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
 490
 491 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
 492 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
 493 ------------------------------------------------------------------------
 494 -- TODO Hierachy of Nodes
 495 -- post and get same types Node' and update if changes
 496
 497 {- TODO semantic to achieve
 498 post c uid pid [ Node' NodeCorpus "name" "{}" []
 499                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 500                                                                     , Node' NodeDocument "title" "jsonData" []
 501                                                                     ]
 502                                           ]
 503                ]
 504 -}
 505 ------------------------------------------------------------------------
 506
 507 -- TODO
 508 -- currently this function remove the child relation
 509 -- needs a Temporary type between Node' and NodeWriteT
 510 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
 511 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
 512                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
 513 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 514
 515
 516 data Node' = Node' { _n_type :: NodeType
 517                    , _n_name :: Text
 518                    , _n_data :: Value
 519                    , _n_children :: [Node']
 520                    } deriving (Show)
 521
 522 -- | TODO NodeWriteT -> NodeWrite
 523 type NodeWriteT =  ( Maybe (Column PGInt4)
 524                    ,        Column PGInt4
 525                    ,        Column PGInt4
 526                    , Maybe (Column PGInt4)
 527                    ,        Column PGText
 528                    , Maybe (Column PGTimestamptz)
 529                    ,        Column PGJsonb
 530                    )
 531
 532 mkNode' :: [NodeWrite] -> Cmd Int64
 533 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
 534
 535 -- TODO: replace mkNodeR'
 536 mkNodeR'' :: [NodeWrite] -> Cmd [Int]
 537 mkNodeR'' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
 538
 539 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
 540 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 541
 542 ------------------------------------------------------------------------
 543
 544 data NewNode = NewNode { _newNodeId :: Int
 545                        , _newNodeChildren :: [Int] }
 546
 547 -- | postNode
 548 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
 549 postNode uid pid (Node' nt txt v []) = do
 550   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
 551   case pids of
 552     [pid] -> pure $ NewNode pid []
 553     _ -> panic "postNode: only one pid expected"
 554
 555 postNode uid pid (Node' NodeCorpus txt v ns) = do
 556   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 557   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 558   pure $ NewNode pid' pids
 559
 560 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 561   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 562   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 563   pure $ NewNode pid' pids
 564 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
 565
 566
 567 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
 568 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 569 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 570 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 571
 572
 573
 574 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
 575 mk c nt pId name  = mk' c nt userId pId name
 576   where
 577     userId = 1
 578
 579 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
 580 mk' c nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
 581   where
 582     hd = HyperdataUser . Just . pack $ show EN
 583
 584 type Name = Text
 585
 586 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
 587 mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
 588 mk'' NodeUser _       _   _     = panic "NodeUser do not have any parent"
 589 mk'' _        Nothing _   _     = panic "NodeType does   have a   parent"
 590 mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 591
 592
 593 mkRoot :: Username -> UserId -> Cmd [Int]
 594 mkRoot uname uId = case uId > 0 of
 595                False -> panic "UserId <= 0"
 596                True  -> mk'' NodeUser Nothing uId uname
 597
 598 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
 599 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
 600
 601 --{-
 602 getOrMkList :: ParentId -> UserId -> Cmd Int
 603 getOrMkList pId uId = do
 604   maybeList <- defaultListSafe' pId
 605   case maybeList of
 606     Nothing -> maybe (panic "no list") identity <$> headMay <$> mkList pId uId
 607     Just x  -> pure x
 608
 609 defaultListSafe' :: CorpusId -> Cmd (Maybe ListId)
 610 defaultListSafe' cId = mkCmd $ \c -> do
 611   maybeNode <- headMay <$> getListsWithParentId c cId
 612   case maybeNode of
 613     Nothing -> pure Nothing
 614     (Just node) -> pure $ Just $ _node_id node
 615 --}
 616
 617 defaultListSafe :: Connection -> CorpusId -> IO (Maybe ListId)
 618 defaultListSafe c cId = do
 619   maybeNode <- headMay <$> getListsWithParentId c cId
 620   case maybeNode of
 621     Nothing -> pure Nothing
 622     (Just node) -> pure $ Just $ _node_id node
 623
 624 defaultList :: Connection -> CorpusId -> IO ListId
 625 defaultList c cId = maybe (panic errMessage) identity <$> defaultListSafe c cId
 626   where
 627     errMessage = "Gargantext.API.Ngrams.defaultList: no list found"
 628
 629 mkList :: ParentId -> UserId -> Cmd [Int]
 630 mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
 631
 632 mkGraph :: ParentId -> UserId -> Cmd [Int]
 633 mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
 634
 635 mkDashboard :: ParentId -> UserId -> Cmd [Int]
 636 mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
 637
 638 mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
 639 mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
 640
 641 -- | Default CorpusId Master and ListId Master
 642