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 nodeContactW :: Maybe Name -> Maybe HyperdataContact
 157              -> AnnuaireId -> UserId -> NodeWrite
 158 nodeContactW maybeName maybeContact aId =
 159   node NodeContact name contact (Just aId)
 160     where
 161       name    = maybe "Contact" identity maybeName
 162       contact = maybe arbitraryHyperdataContact identity maybeContact
 163 ------------------------------------------------------------------------
 164 defaultFolder :: HyperdataCorpus
 165 defaultFolder = defaultCorpus
 166
 167 nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 168 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 169   where
 170     name   = maybe "Folder" identity maybeName
 171     folder = maybe defaultFolder identity maybeFolder
 172 ------------------------------------------------------------------------
 173 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 174 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 175   where
 176     name   = maybe "Corpus" identity maybeName
 177     corpus = maybe defaultCorpus identity maybeCorpus
 178                    --------------------------
 179 defaultDocument :: HyperdataDocument
 180 defaultDocument = hyperdataDocument
 181
 182 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
 183 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
 184   where
 185     name = maybe "Document" identity maybeName
 186     doc  = maybe defaultDocument identity maybeDocument
 187 ------------------------------------------------------------------------
 188 defaultAnnuaire :: HyperdataAnnuaire
 189 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 190
 191 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 192 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 193   where
 194     name     = maybe "Annuaire" identity maybeName
 195     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 196
 197 ------------------------------------------------------------------------
 198
 199 {-
 200 class IsNodeDb a where
 201   data Node'' a :: *
 202   data Hyper  a :: *
 203
 204 instance IsNodeDb NodeType where
 205   data
 206
 207 instance HasHyperdata NodeType where
 208   data Hyper NodeType = HyperList   HyperdataList
 209                       | HyperCorpus HyperdataCorpus
 210
 211   hasHyperdata nt = case nt of
 212     NodeList   -> HyperList $ HyperdataList (Just "list")
 213
 214   unHyper h = case h of
 215     HyperList h' -> h'
 216
 217 --}
 218
 219
 220 class HasDefault a where
 221   hasDefaultData :: a -> HyperData
 222   hasDefaultName :: a -> Text
 223
 224 instance HasDefault NodeType where
 225   hasDefaultData nt = case nt of
 226       NodeTexts    -> HyperdataTexts (Just "Preferences")
 227       NodeList     -> HyperdataList' (Just "Preferences")
 228       NodeListCooc -> HyperdataList' (Just "Preferences")
 229       _         -> undefined
 230       --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
 231
 232   hasDefaultName nt = case nt of
 233       NodeTexts -> "Texts"
 234       NodeList  -> "Lists"
 235       NodeListCooc -> "Cooc"
 236       _         -> undefined
 237
 238 ------------------------------------------------------------------------
 239 nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
 240 nodeDefault nt parent = node nt name hyper (Just parent)
 241   where
 242     name  = (hasDefaultName nt)
 243     hyper = (hasDefaultData nt)
 244
 245 ------------------------------------------------------------------------
 246 arbitraryListModel :: HyperdataListModel
 247 arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
 248
 249 mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 250 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
 251
 252 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
 253 nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
 254   where
 255     name = maybe "List Model" identity maybeName
 256     list = maybe arbitraryListModel identity maybeListModel
 257
 258 ------------------------------------------------------------------------
 259 arbitraryGraph :: HyperdataGraph
 260 arbitraryGraph = HyperdataGraph Nothing
 261
 262 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 263 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 264   where
 265     name = maybe "Graph" identity maybeName
 266     graph = maybe arbitraryGraph identity maybeGraph
 267
 268 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 269 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 270
 271 insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
 272 insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
 273
 274 ------------------------------------------------------------------------
 275 arbitraryPhylo :: HyperdataPhylo
 276 arbitraryPhylo = HyperdataPhylo Nothing Nothing
 277
 278 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 279 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 280   where
 281     name = maybe "Phylo" identity maybeName
 282     graph = maybe arbitraryPhylo identity maybePhylo
 283
 284 ------------------------------------------------------------------------
 285 arbitraryDashboard :: HyperdataDashboard
 286 arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
 287 ------------------------------------------------------------------------
 288
 289 node :: (ToJSON a, Hyperdata a)
 290      => NodeType
 291      -> Name
 292      -> a
 293      -> Maybe ParentId
 294      -> UserId
 295      -> NodeWrite
 296 node nodeType name hyperData parentId userId =
 297   Node Nothing
 298        (pgInt4 typeId)
 299        (pgInt4 userId)
 300        (pgNodeId <$> parentId)
 301        (pgStrictText name)
 302        Nothing
 303        (pgJSONB $ cs $ encode hyperData)
 304     where
 305       typeId = nodeTypeId nodeType
 306
 307                   -------------------------------
 308 insertNodes :: [NodeWrite] -> Cmd err Int64
 309 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 310
 311 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 312 insertNodesR ns = mkCmd $ \conn ->
 313   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 314
 315 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 316 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 317
 318 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 319 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 320 ------------------------------------------------------------------------
 321 -- TODO Hierachy of Nodes
 322 -- post and get same types Node' and update if changes
 323
 324 {- TODO semantic to achieve
 325 post c uid pid [ Node' NodeCorpus "name" "{}" []
 326                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 327                                                                     , Node' NodeDocument "title" "jsonData" []
 328                                                                     ]
 329                                           ]
 330                ]
 331 -}
 332 ------------------------------------------------------------------------
 333
 334 -- TODO
 335 -- currently this function removes the child relation
 336 -- needs a Temporary type between Node' and NodeWriteT
 337
 338 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 339 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 340 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 341
 342
 343 data Node' = Node' { _n_type :: NodeType
 344                    , _n_name :: Text
 345                    , _n_data :: Value
 346                    , _n_children :: [Node']
 347                    } deriving (Show)
 348
 349 mkNodes :: [NodeWrite] -> Cmd err Int64
 350 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 351                    $ Insert nodeTable ns rCount Nothing
 352
 353 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 354 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 355
 356 ------------------------------------------------------------------------
 357
 358 {-
 359 data NewNode = NewNode { _newNodeId :: NodeId
 360                        , _newNodeChildren :: [NodeId] }
 361
 362 postNode :: HasNodeError err
 363          => UserId
 364          -> Maybe ParentId
 365          -> Node'
 366          -> Cmd err NewNode
 367
 368 postNode uid pid (Node' nt txt v []) = do
 369   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
 370   case pids of
 371     [pid'] -> pure $ NewNode pid' []
 372     _ -> nodeError ManyParents
 373
 374 postNode uid pid (Node' NodeCorpus txt v ns) = do
 375   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 376   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 377   pure $ NewNode pid' pids
 378
 379 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 380   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 381   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 382   pure $ NewNode pid' pids
 383
 384 postNode uid pid (Node' NodeDashboard txt v ns) = do
 385   NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
 386   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
 387   pure $ NewNode pid' pids
 388
 389 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 390 -}
 391
 392 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 393 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 394 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 395 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 396
 397
 398 -- =================================================================== --
 399 -- |
 400 -- CorpusDocument is a corpus made from a set of documents
 401 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 402 data CorpusType = CorpusDocument | CorpusContact
 403
 404 class MkCorpus a
 405   where
 406     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 407
 408 instance MkCorpus HyperdataCorpus
 409   where
 410     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 411
 412
 413 instance MkCorpus HyperdataAnnuaire
 414   where
 415     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 416
 417
 418 getOrMkList :: HasNodeError err
 419             => ParentId
 420             -> UserId
 421             -> Cmd err ListId
 422 getOrMkList pId uId =
 423   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 424     where
 425       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 426
 427 mkList :: HasNodeError err
 428             => ParentId
 429             -> UserId
 430             -> Cmd err [ListId]
 431 mkList pId uId = mkNode NodeList pId uId
 432
 433 -- | TODO remove defaultList
 434 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 435 defaultList cId =
 436   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 437
 438 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 439 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 440
 441 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 442 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 443   where
 444     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 445     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 446       where
 447         name = maybe "Board" identity maybeName
 448         dashboard = maybe arbitraryDashboard identity maybeDashboard
 449
 450
 451 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 452 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 453
 454 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 455 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 456
 457 -- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 458 -- updateNodeUser_fake :: NodeId -> Cmd err Int64
 459 -- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
 460