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

   1 {-|
   2 Module      : Gargantext.Database.Tools.Node
   3 Description : Main Tools of Node to the database
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE DeriveGeneric          #-}
  16 {-# LANGUAGE ConstraintKinds        #-}
  17 {-# LANGUAGE FlexibleContexts       #-}
  18 {-# LANGUAGE FlexibleInstances      #-}
  19 {-# LANGUAGE FunctionalDependencies #-}
  20 {-# LANGUAGE OverloadedStrings      #-}
  21 {-# LANGUAGE MultiParamTypeClasses  #-}
  22 {-# LANGUAGE NoImplicitPrelude      #-}
  23 {-# LANGUAGE RankNTypes             #-}
  24 {-# LANGUAGE TemplateHaskell        #-}
  25 {-# LANGUAGE TypeFamilies           #-}
  26
  27 module Gargantext.Database.Action.Query.Node
  28   where
  29
  30 import Control.Arrow (returnA)
  31 import Control.Lens (set, view)
  32 import Data.Aeson
  33 import Data.Maybe (Maybe(..), fromMaybe)
  34 import Data.Text (Text)
  35 import GHC.Int (Int64)
  36 import Gargantext.Core.Types
  37 import Gargantext.Database.Action.Query.Filter (limit', offset')
  38 import Gargantext.Database.Admin.Config (nodeTypeId)
  39 import Gargantext.Database.Admin.Types.Errors
  40 import Gargantext.Database.Admin.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
  41 import Gargantext.Database.Admin.Utils
  42 import Gargantext.Database.Action.Query.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
  43 import Gargantext.Database.Schema.Node
  44 import Gargantext.Prelude hiding (sum, head)
  45 import Gargantext.Viz.Graph (HyperdataGraph(..))
  46 import Opaleye hiding (FromField)
  47 import Opaleye.Internal.QueryArr (Query)
  48 import Prelude hiding (null, id, map, sum)
  49
  50
  51 queryNodeSearchTable :: Query NodeSearchRead
  52 queryNodeSearchTable = queryTable nodeTableSearch
  53
  54 selectNode :: Column PGInt4 -> Query NodeRead
  55 selectNode id = proc () -> do
  56     row <- queryNodeTable -< ()
  57     restrict -< _node_id row .== id
  58     returnA -< row
  59
  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 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 345 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 346 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 347
 348
 349
 350 data Node' = Node' { _n_type :: NodeType
 351                    , _n_name :: Text
 352                    , _n_data :: Value
 353                    , _n_children :: [Node']
 354                    } deriving (Show)
 355
 356 mkNodes :: [NodeWrite] -> Cmd err Int64
 357 mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 358
 359 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 360 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 361
 362 ------------------------------------------------------------------------
 363
 364 data NewNode = NewNode { _newNodeId :: NodeId
 365                        , _newNodeChildren :: [NodeId] }
 366
 367 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
 368
 369 postNode uid pid (Node' nt txt v []) = do
 370   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 371   case pids of
 372     [pid'] -> pure $ NewNode pid' []
 373     _ -> nodeError ManyParents
 374
 375 postNode uid pid (Node' NodeCorpus txt v ns) = do
 376   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 377   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 378   pure $ NewNode pid' pids
 379
 380 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 381   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 382   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 383   pure $ NewNode pid' pids
 384
 385 postNode uid pid (Node' NodeDashboard txt v ns) = do
 386   NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
 387   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 388   pure $ NewNode pid' pids
 389
 390 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 391
 392
 393 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 394 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 395 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 396 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 397
 398
 399 -- =================================================================== --
 400 -- |
 401 -- CorpusDocument is a corpus made from a set of documents
 402 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 403 data CorpusType = CorpusDocument | CorpusContact
 404
 405 class MkCorpus a
 406   where
 407     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 408
 409 instance MkCorpus HyperdataCorpus
 410   where
 411     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 412
 413
 414 instance MkCorpus HyperdataAnnuaire
 415   where
 416     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 417
 418
 419 getOrMkList :: HasNodeError err
 420             => ParentId
 421             -> UserId
 422             -> Cmd err ListId
 423 getOrMkList pId uId =
 424   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 425     where
 426       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 427
 428 mkList :: HasNodeError err
 429             => ParentId
 430             -> UserId
 431             -> Cmd err [ListId]
 432 mkList pId uId = mkNode NodeList pId uId
 433
 434 -- | TODO remove defaultList
 435 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 436 defaultList cId =
 437   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 438
 439 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 440 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 441
 442 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 443 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 444   where
 445     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 446     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 447       where
 448         name = maybe "Board" identity maybeName
 449         dashboard = maybe arbitraryDashboard identity maybeDashboard
 450
 451
 452 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 453 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 454
 455 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 456 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 457
 458 -- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 459 -- updateNodeUser_fake :: NodeId -> Cmd err Int64
 460 -- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
 461