src/Gargantext/Database/Node.hs

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