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