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