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