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