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