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
 276                   parentId nodeType maybeOffset maybeLimit
 277
 278
 279 -- NP check type
 280 getNodesWithParentId :: Int
 281                      -> Maybe Text -> Connection -> IO [NodeAny]
 282 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 283
 284 getNodesWithParentId' :: Int
 285                      -> Maybe Text -> Connection -> IO [NodeAny]
 286 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 287
 288
 289 ------------------------------------------------------------------------
 290 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 291 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 292
 293 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 294 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 295
 296 getListsWithParentId :: Connection -> Int -> IO [Node HyperdataList]
 297 getListsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeList)
 298
 299 ------------------------------------------------------------------------
 300 selectNodesWithParentID :: Int -> Query NodeRead
 301 selectNodesWithParentID n = proc () -> do
 302     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 303     restrict -< if n > 0
 304       then parent_id .== (toNullable $ pgInt4 n)
 305       else isNull parent_id
 306     returnA -< row
 307
 308 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 309 selectNodesWithType type_id = proc () -> do
 310     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 311     restrict -< tn .== type_id
 312     returnA -< row
 313
 314 type JSONB = QueryRunnerColumnDefault PGJsonb
 315
 316 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
 317 getNode conn id _ = do
 318     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 319
 320 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 321 getNodesWithType conn type_id = do
 322     runQuery conn $ selectNodesWithType type_id
 323
 324 ------------------------------------------------------------------------
 325 -- WIP
 326 -- TODO Classe HasDefault where
 327 -- default NodeType = Hyperdata
 328 ------------------------------------------------------------------------
 329 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 330 ------------------------------------------------------------------------
 331 defaultUser :: HyperdataUser
 332 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 333
 334 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
 335 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 336   where
 337     name = maybe "User" identity maybeName
 338     user = maybe defaultUser identity maybeHyperdata
 339 ------------------------------------------------------------------------
 340 defaultFolder :: HyperdataFolder
 341 defaultFolder = HyperdataFolder (Just "Markdown Description")
 342
 343 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
 344 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 345   where
 346     name   = maybe "Folder" identity maybeName
 347     folder = maybe defaultFolder identity maybeFolder
 348 ------------------------------------------------------------------------
 349 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
 350 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 351   where
 352     name   = maybe "Corpus" identity maybeName
 353     corpus = maybe defaultCorpus identity maybeCorpus
 354                    --------------------------
 355 defaultDocument :: HyperdataDocument
 356 defaultDocument = hyperdataDocument
 357
 358 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
 359 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 360   where
 361     name = maybe "Document" identity maybeName
 362     doc  = maybe defaultDocument identity maybeDocument
 363 ------------------------------------------------------------------------
 364 defaultAnnuaire :: HyperdataAnnuaire
 365 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 366
 367 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
 368 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 369   where
 370     name     = maybe "Annuaire" identity maybeName
 371     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 372                    --------------------------
 373
 374 ------------------------------------------------------------------------
 375 arbitraryList :: HyperdataList
 376 arbitraryList = HyperdataList (Just "Preferences")
 377
 378 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite'
 379 nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
 380   where
 381     name = maybe "Listes" identity maybeName
 382     list = maybe arbitraryList identity maybeList
 383
 384 ------------------------------------------------------------------------
 385 arbitraryGraph :: HyperdataGraph
 386 arbitraryGraph = HyperdataGraph (Just "Preferences")
 387
 388 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite'
 389 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 390   where
 391     name = maybe "Graph" identity maybeName
 392     graph = maybe arbitraryGraph identity maybeGraph
 393
 394 ------------------------------------------------------------------------
 395
 396 arbitraryDashboard :: HyperdataDashboard
 397 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
 398
 399 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite'
 400 nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 401   where
 402     name = maybe "Dashboard" identity maybeName
 403     dashboard = maybe arbitraryDashboard identity maybeDashboard
 404
 405
 406
 407 ------------------------------------------------------------------------
 408 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
 409 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
 410   where
 411     typeId = nodeTypeId nodeType
 412     byteData = DB.pack . DBL.unpack $ encode hyperData
 413
 414                   -------------------------------
 415 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
 416               NodePoly (maybe2 Int)                      Int            Int  (maybe1           Int)
 417                                 Text        (maybe3 UTCTime)             ByteString
 418                     -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
 419                      , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
 420 node2row (Node id tn ud pid nm dt hp) = ((pgInt4    <$> id)
 421                                         ,(pgInt4        tn)
 422                                         ,(pgInt4        ud)
 423                                         ,(pgInt4   <$> pid)
 424                                         ,(pgStrictText  nm)
 425                                         ,(pgUTCTime <$> dt)
 426                                         ,(pgStrictJSONB hp)
 427                                         )
 428 ------------------------------------------------------------------------
 429 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
 430 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
 431
 432 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
 433 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
 434
 435 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
 436 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
 437                        -------------------------
 438 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
 439 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
 440
 441 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
 442 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
 443 ------------------------------------------------------------------------
 444 -- TODO Hierachy of Nodes
 445 -- post and get same types Node' and update if changes
 446
 447 {- TODO semantic to achieve
 448 post c uid pid [ Node' NodeCorpus "name" "{}" []
 449                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 450                                                                     , Node' NodeDocument "title" "jsonData" []
 451                                                                     ]
 452                                           ]
 453                ]
 454 -}
 455 ------------------------------------------------------------------------
 456
 457 -- TODO
 458 -- currently this function remove the child relation
 459 -- needs a Temporary type between Node' and NodeWriteT
 460 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
 461 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
 462                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
 463 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 464
 465
 466 data Node' = Node' { _n_type :: NodeType
 467                    , _n_name :: Text
 468                    , _n_data :: Value
 469                    , _n_children :: [Node']
 470                    } deriving (Show)
 471
 472
 473 type NodeWriteT =  ( Maybe (Column PGInt4)
 474                    ,        Column PGInt4
 475                    ,        Column PGInt4
 476                    , Maybe (Column PGInt4)
 477                    ,        Column PGText
 478                    , Maybe (Column PGTimestamptz)
 479                    ,        Column PGJsonb
 480                    )
 481
 482
 483 mkNode' :: [NodeWriteT] -> Cmd Int64
 484 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
 485
 486 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
 487 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 488
 489 ------------------------------------------------------------------------
 490
 491 data NewNode = NewNode { _newNodeId :: Int
 492                        , _newNodeChildren :: [Int] }
 493
 494 -- | postNode
 495 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
 496 postNode uid pid (Node' nt txt v []) = do
 497   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
 498   case pids of
 499     [pid] -> pure $ NewNode pid []
 500     _ -> panic "postNode: only one pid expected"
 501
 502 postNode uid pid (Node' NodeCorpus txt v ns) = do
 503   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 504   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 505   pure $ NewNode pid' pids
 506
 507 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 508   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 509   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 510   pure $ NewNode pid' pids
 511 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
 512
 513
 514 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
 515 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 516 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 517 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 518
 519
 520 -- TODO: remove hardcoded userId (with Reader)
 521 -- TODO: user Reader in the API and adapt this function
 522 userId :: Int
 523 userId = 1
 524
 525 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
 526 mk c nt pId name  = mk' c nt userId pId name
 527
 528 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
 529 mk' c nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
 530   where
 531     hd = HyperdataUser . Just . pack $ show EN
 532
 533 type Name = Text
 534
 535 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
 536 mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
 537 mk'' NodeUser _       _   _     = panic "NodeUser do not have any parent"
 538 mk'' _        Nothing _   _     = panic "NodeType does   have a   parent"
 539 mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 540
 541 type Username = Text
 542
 543 mkRoot :: Username -> UserId -> Cmd [Int]
 544 mkRoot uname uId = case uId > 0 of
 545                False -> panic "UserId <= 0"
 546                True  -> mk'' NodeUser Nothing uId uname
 547
 548 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
 549 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
 550
 551 mkList :: ParentId -> UserId -> Cmd [Int]
 552 mkList p u = insertNodesR' [nodeListW Nothing Nothing p u]
 553
 554 mkGraph :: ParentId -> UserId -> Cmd [Int]
 555 mkGraph p u = insertNodesR' [nodeGraphW Nothing Nothing p u]
 556
 557 mkDashboard :: ParentId -> UserId -> Cmd [Int]
 558 mkDashboard p u = insertNodesR' [nodeDashboardW Nothing Nothing p u]
 559
 560 mkAnnuaire :: ParentId -> UserId -> Cmd [Int]
 561 mkAnnuaire p u = insertNodesR' [nodeAnnuaireW Nothing Nothing p u]
 562
 563 -- | Default CorpusId Master and ListId Master
 564