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