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