src/Gargantext/Database/Query/Table/Node.hs

   1 {-|
   2 import Gargantext.Database.Prelude (Cmd, runPGSQuery)
   3 Module      : Gargantext.Database.Query.Table.Node
   4 Description : Main Tools of Node to the database
   5 Copyright   : (c) CNRS, 2017-Present
   6 License     : AGPL + CECILL v3
   7 Maintainer  : team@gargantext.org
   8 Stability   : experimental
   9 Portability : POSIX
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  13 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  14
  15 {-# LANGUAGE Arrows                 #-}
  16 {-# LANGUAGE DeriveGeneric          #-}
  17 {-# LANGUAGE ConstraintKinds        #-}
  18 {-# LANGUAGE FlexibleContexts       #-}
  19 {-# LANGUAGE FlexibleInstances      #-}
  20 {-# LANGUAGE FunctionalDependencies #-}
  21 {-# LANGUAGE OverloadedStrings      #-}
  22 {-# LANGUAGE MultiParamTypeClasses  #-}
  23 {-# LANGUAGE NoImplicitPrelude      #-}
  24 {-# LANGUAGE RankNTypes             #-}
  25 {-# LANGUAGE TemplateHaskell        #-}
  26 {-# LANGUAGE TypeFamilies           #-}
  27
  28 module Gargantext.Database.Query.Table.Node
  29   where
  30
  31 import Control.Arrow (returnA)
  32 import Control.Lens (set, view)
  33 import Data.Aeson
  34 import Data.Maybe (Maybe(..), fromMaybe)
  35 import Data.Text (Text)
  36 import GHC.Int (Int64)
  37 import Gargantext.Core.Types
  38 import Gargantext.Database.Query.Filter (limit', offset')
  39 import Gargantext.Database.Admin.Config (nodeTypeId)
  40 import Gargantext.Database.Query.Table.Node.Error
  41 import Gargantext.Database.Admin.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
  42 import Gargantext.Database.Prelude
  43 import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
  44 import Gargantext.Database.Schema.Node
  45 import Gargantext.Prelude hiding (sum, head)
  46 import Gargantext.Viz.Graph (HyperdataGraph(..))
  47 import Opaleye hiding (FromField)
  48 import Opaleye.Internal.QueryArr (Query)
  49 import Prelude hiding (null, id, map, sum)
  50
  51
  52 queryNodeSearchTable :: Query NodeSearchRead
  53 queryNodeSearchTable = queryTable nodeTableSearch
  54
  55 selectNode :: Column PGInt4 -> Query NodeRead
  56 selectNode id = proc () -> do
  57     row <- queryNodeTable -< ()
  58     restrict -< _node_id row .== id
  59     returnA -< row
  60
  61 runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
  62 runGetNodes = runOpaQuery
  63
  64 ------------------------------------------------------------------------
  65 ------------------------------------------------------------------------
  66 -- | order by publication date
  67 -- Favorites (Bool), node_ngrams
  68 selectNodesWith :: ParentId     -> Maybe NodeType
  69                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
  70 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
  71         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
  72   limit' maybeLimit $ offset' maybeOffset
  73                     $ orderBy (asc _node_id)
  74                     $ selectNodesWith' parentId maybeNodeType
  75
  76 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
  77 selectNodesWith' parentId maybeNodeType = proc () -> do
  78     node <- (proc () -> do
  79       row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
  80       restrict -< parentId' .== (pgNodeId parentId)
  81
  82       let typeId' = maybe 0 nodeTypeId maybeNodeType
  83
  84       restrict -< if typeId' > 0
  85                      then typeId   .== (pgInt4 (typeId' :: Int))
  86                      else (pgBool True)
  87       returnA  -< row ) -< ()
  88     returnA -< node
  89
  90 deleteNode :: NodeId -> Cmd err Int
  91 deleteNode n = mkCmd $ \conn ->
  92   fromIntegral <$> runDelete conn nodeTable
  93                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
  94
  95 deleteNodes :: [NodeId] -> Cmd err Int
  96 deleteNodes ns = mkCmd $ \conn ->
  97   fromIntegral <$> runDelete conn nodeTable
  98                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
  99
 100 -- TODO: NodeType should match with `a'
 101 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
 102              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 103 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 104     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 105
 106 -- TODO: Why is the second parameter ignored?
 107 -- TODO: Why not use getNodesWith?
 108 getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
 109                      => Maybe NodeId
 110                      -> Cmd err [Node a]
 111 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 112   where
 113     n' = case n of
 114       Just n'' -> n''
 115       Nothing  -> 0
 116
 117 ------------------------------------------------------------------------
 118 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 119 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 120
 121 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 122 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 123 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 124
 125 getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
 126 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
 127
 128 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 129 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 130
 131 ------------------------------------------------------------------------
 132 selectNodesWithParentID :: NodeId -> Query NodeRead
 133 selectNodesWithParentID n = proc () -> do
 134     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 135     restrict -< parent_id .== (pgNodeId n)
 136     returnA -< row
 137
 138 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 139 selectNodesWithType type_id = proc () -> do
 140     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 141     restrict -< tn .== type_id
 142     returnA -< row
 143
 144 type JSONB = QueryRunnerColumnDefault PGJsonb
 145
 146
 147 getNode :: NodeId -> Cmd err (Node Value)
 148 getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 149              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 150
 151 getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 152 getNodeWith nId _ = do
 153     fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 154              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 155
 156
 157 getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
 158 getNodePhylo nId = do
 159     fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
 160              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 161
 162
 163 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 164 getNodesWithType = runOpaQuery . selectNodesWithType
 165
 166 ------------------------------------------------------------------------
 167 nodeContactW :: Maybe Name -> Maybe HyperdataContact
 168              -> AnnuaireId -> UserId -> NodeWrite
 169 nodeContactW maybeName maybeContact aId =
 170   node NodeContact name contact (Just aId)
 171     where
 172       name    = maybe "Contact" identity maybeName
 173       contact = maybe arbitraryHyperdataContact identity maybeContact
 174 ------------------------------------------------------------------------
 175 defaultFolder :: HyperdataCorpus
 176 defaultFolder = defaultCorpus
 177
 178 nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 179 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 180   where
 181     name   = maybe "Folder" identity maybeName
 182     folder = maybe defaultFolder identity maybeFolder
 183 ------------------------------------------------------------------------
 184 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 185 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 186   where
 187     name   = maybe "Corpus" identity maybeName
 188     corpus = maybe defaultCorpus identity maybeCorpus
 189                    --------------------------
 190 defaultDocument :: HyperdataDocument
 191 defaultDocument = hyperdataDocument
 192
 193 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 194 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 195   where
 196     name = maybe "Document" identity maybeName
 197     doc  = maybe defaultDocument identity maybeDocument
 198 ------------------------------------------------------------------------
 199 defaultAnnuaire :: HyperdataAnnuaire
 200 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 201
 202 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 203 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 204   where
 205     name     = maybe "Annuaire" identity maybeName
 206     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 207
 208 ------------------------------------------------------------------------
 209
 210 {-
 211 class IsNodeDb a where
 212   data Node'' a :: *
 213   data Hyper  a :: *
 214
 215 instance IsNodeDb NodeType where
 216   data
 217
 218 instance HasHyperdata NodeType where
 219   data Hyper NodeType = HyperList   HyperdataList
 220                       | HyperCorpus HyperdataCorpus
 221
 222   hasHyperdata nt = case nt of
 223     NodeList   -> HyperList $ HyperdataList (Just "list")
 224
 225   unHyper h = case h of
 226     HyperList h' -> h'
 227
 228 --}
 229
 230
 231 class HasDefault a where
 232   hasDefaultData :: a -> HyperData
 233   hasDefaultName :: a -> Text
 234
 235 instance HasDefault NodeType where
 236   hasDefaultData nt = case nt of
 237       NodeTexts -> HyperdataTexts (Just "Preferences")
 238       NodeList  -> HyperdataList' (Just "Preferences")
 239       NodeListCooc -> HyperdataList' (Just "Preferences")
 240       _         -> undefined
 241       --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
 242
 243   hasDefaultName nt = case nt of
 244       NodeTexts -> "Texts"
 245       NodeList  -> "Lists"
 246       NodeListCooc -> "Cooc"
 247       _         -> undefined
 248
 249 ------------------------------------------------------------------------
 250
 251 nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
 252 nodeDefault nt parent = node nt name hyper (Just parent)
 253   where
 254     name  = (hasDefaultName nt)
 255     hyper = (hasDefaultData nt)
 256
 257 ------------------------------------------------------------------------
 258 arbitraryListModel :: HyperdataListModel
 259 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 260
 261 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 262 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 263
 264 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 265 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 266   where
 267     name = maybe "List Model" identity maybeName
 268     list = maybe arbitraryListModel identity maybeListModel
 269
 270 ------------------------------------------------------------------------
 271 arbitraryGraph :: HyperdataGraph
 272 arbitraryGraph = HyperdataGraph Nothing
 273
 274 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 275 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 276   where
 277     name = maybe "Graph" identity maybeName
 278     graph = maybe arbitraryGraph identity maybeGraph
 279
 280 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 281 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 282
 283 insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
 284 insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
 285
 286 ------------------------------------------------------------------------
 287 arbitraryPhylo :: HyperdataPhylo
 288 arbitraryPhylo = HyperdataPhylo Nothing Nothing
 289
 290 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 291 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 292   where
 293     name = maybe "Phylo" identity maybeName
 294     graph = maybe arbitraryPhylo identity maybePhylo
 295
 296
 297 ------------------------------------------------------------------------
 298 arbitraryDashboard :: HyperdataDashboard
 299 arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
 300 ------------------------------------------------------------------------
 301
 302 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
 303 node nodeType name hyperData parentId userId =
 304   Node Nothing
 305        (pgInt4 typeId)
 306        (pgInt4 userId)
 307        (pgNodeId <$> parentId)
 308        (pgStrictText name)
 309        Nothing
 310        (pgJSONB $ cs $ encode hyperData)
 311     where
 312       typeId = nodeTypeId nodeType
 313
 314                   -------------------------------
 315 insertNodes :: [NodeWrite] -> Cmd err Int64
 316 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 317
 318 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 319 insertNodesR ns = mkCmd $ \conn ->
 320   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 321
 322 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 323 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 324
 325 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 326 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 327 ------------------------------------------------------------------------
 328 -- TODO Hierachy of Nodes
 329 -- post and get same types Node' and update if changes
 330
 331 {- TODO semantic to achieve
 332 post c uid pid [ Node' NodeCorpus "name" "{}" []
 333                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 334                                                                     , Node' NodeDocument "title" "jsonData" []
 335                                                                     ]
 336                                           ]
 337                ]
 338 -}
 339 ------------------------------------------------------------------------
 340
 341 -- TODO
 342 -- currently this function removes the child relation
 343 -- needs a Temporary type between Node' and NodeWriteT
 344
 345 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 346 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 347 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 348
 349
 350
 351 data Node' = Node' { _n_type :: NodeType
 352                    , _n_name :: Text
 353                    , _n_data :: Value
 354                    , _n_children :: [Node']
 355                    } deriving (Show)
 356
 357 mkNodes :: [NodeWrite] -> Cmd err Int64
 358 mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 359
 360 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 361 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 362
 363 ------------------------------------------------------------------------
 364
 365 data NewNode = NewNode { _newNodeId :: NodeId
 366                        , _newNodeChildren :: [NodeId] }
 367
 368 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 369
 370 postNode uid pid (Node' nt txt v []) = do
 371   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 372   case pids of
 373     [pid'] -> pure $ NewNode pid' []
 374     _ -> nodeError ManyParents
 375
 376 postNode uid pid (Node' NodeCorpus txt v ns) = do
 377   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 378   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 379   pure $ NewNode pid' pids
 380
 381 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 382   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 383   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 384   pure $ NewNode pid' pids
 385
 386 postNode uid pid (Node' NodeDashboard txt v ns) = do
 387   NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
 388   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 389   pure $ NewNode pid' pids
 390
 391 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 392
 393
 394 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 395 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 396 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 397 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 398
 399
 400 -- =================================================================== --
 401 -- |
 402 -- CorpusDocument is a corpus made from a set of documents
 403 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 404 data CorpusType = CorpusDocument | CorpusContact
 405
 406 class MkCorpus a
 407   where
 408     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 409
 410 instance MkCorpus HyperdataCorpus
 411   where
 412     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 413
 414
 415 instance MkCorpus HyperdataAnnuaire
 416   where
 417     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 418
 419
 420 getOrMkList :: HasNodeError err
 421             => ParentId
 422             -> UserId
 423             -> Cmd err ListId
 424 getOrMkList pId uId =
 425   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 426     where
 427       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 428
 429 mkList :: HasNodeError err
 430             => ParentId
 431             -> UserId
 432             -> Cmd err [ListId]
 433 mkList pId uId = mkNode NodeList pId uId
 434
 435 -- | TODO remove defaultList
 436 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 437 defaultList cId =
 438   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 439
 440 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 441 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 442
 443 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 444 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 445   where
 446     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 447     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 448       where
 449         name = maybe "Board" identity maybeName
 450         dashboard = maybe arbitraryDashboard identity maybeDashboard
 451
 452
 453 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 454 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 455
 456 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 457 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 458
 459 -- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 460 -- updateNodeUser_fake :: NodeId -> Cmd err Int64
 461 -- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
 462