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