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.Admin.Config (nodeTypeId)
  32 import Gargantext.Database.Admin.Types.Hyperdata
  33 import Gargantext.Database.Admin.Types.Node (NodeType(..))
  34 import Gargantext.Database.Prelude
  35 import Gargantext.Database.Query.Filter (limit', offset')
  36 import Gargantext.Database.Query.Table.Node.Error
  37 import Gargantext.Database.Schema.Node
  38 import Gargantext.Prelude hiding (sum, head)
  39 import Gargantext.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph)
  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 HyperdataModel]
 119 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 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 :: HyperdataFolder
 166 defaultFolder = defaultHyperdataFolder
 167
 168
 169 nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 170 nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
 171   where
 172     name   = maybe "Folder" identity maybeName
 173     folder = maybe defaultFolder identity maybeFolder
 174 ------------------------------------------------------------------------
 175 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
 176 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
 177   where
 178     name   = maybe "Corpus" identity maybeName
 179     corpus = maybe defaultHyperdataCorpus identity maybeCorpus
 180                    --------------------------
 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 defaultHyperdataDocument identity maybeDocument
 187 ------------------------------------------------------------------------
 188 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
 189 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
 190   where
 191     name     = maybe "Annuaire" identity maybeName
 192     annuaire = maybe defaultHyperdataAnnuaire identity maybeAnnuaire
 193
 194 ------------------------------------------------------------------------
 195 mkModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 196 mkModelNode p u = insertNodesR [nodeModelW Nothing Nothing p u]
 197
 198 nodeModelW :: Maybe Name -> Maybe HyperdataModel -> ParentId -> UserId -> NodeWrite
 199 nodeModelW maybeName maybeModel pId = node NodeModel name list (Just pId)
 200   where
 201     name = maybe "List Model" identity maybeName
 202     list = maybe defaultHyperdataModel identity maybeModel
 203
 204 ------------------------------------------------------------------------
 205 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 206 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 207   where
 208     name = maybe "Graph" identity maybeName
 209     graph = maybe defaultHyperdataGraph identity maybeGraph
 210
 211 mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
 212 mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 213
 214 insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
 215 insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
 216
 217 ------------------------------------------------------------------------
 218 nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
 219 nodeDefault NodeUser      parentId = node NodeUser     "User"   defaultHyperdataUser     (Just parentId)
 220 nodeDefault NodeContact   parentId = node NodeContact  "Contact" defaultHyperdataContact   (Just parentId)
 221
 222 nodeDefault NodeCorpus    parentId = node NodeCorpus   "Corpus" defaultHyperdataCorpus   (Just parentId)
 223 nodeDefault NodeCorpusV3  parentId = node NodeCorpus   "Corpus" defaultHyperdataCorpus   (Just parentId)
 224 nodeDefault NodeAnnuaire  parentId = node NodeAnnuaire "Annuaire" defaultHyperdataAnnuaire   (Just parentId)
 225
 226 nodeDefault NodeDocument  parentId = node NodeDocument "Doc"    defaultHyperdataDocument (Just parentId)
 227 nodeDefault NodeTexts     parentId = node NodeTexts    "Texts"  defaultHyperdataTexts    (Just parentId)
 228 nodeDefault NodeList      parentId = node NodeList     "List"   defaultHyperdataList     (Just parentId)
 229 nodeDefault NodeListCooc  parentId = node NodeListCooc "List"   defaultHyperdataListCooc (Just parentId)
 230 nodeDefault NodeModel     parentId = node NodeModel    "Model"  defaultHyperdataModel    (Just parentId)
 231
 232 nodeDefault NodeFolder    parentId = node NodeFolder   "Folder" defaultHyperdataFolder   (Just parentId)
 233 nodeDefault NodeFolderPrivate parentId = node NodeFolderPrivate  "Private Folder" defaultHyperdataFolderPrivate   (Just parentId)
 234 nodeDefault NodeFolderShared  parentId = node NodeFolderShared   "Shared Folder"  defaultHyperdataFolderShared   (Just parentId)
 235 nodeDefault NodeTeam          parentId = node NodeFolder  "Folder" defaultHyperdataFolder  (Just parentId)
 236 nodeDefault NodeFolderPublic  parentId = node NodeFolderPublic   "Public Folder"  defaultHyperdataFolderPublic   (Just parentId)
 237
 238 nodeDefault NodeGraph         parentId = node NodeGraph   "Graph"  defaultHyperdataGraph   (Just parentId)
 239 nodeDefault NodePhylo         parentId = node NodePhylo   "Phylo"  defaultHyperdataPhylo   (Just parentId)
 240 nodeDefault NodeDashboard     parentId = node NodeDashboard   "Dashboard"  defaultHyperdataDashboard   (Just parentId)
 241
 242 nodeDefault NodeFrameWrite   parentId = node NodeFrameWrite "Frame Write"  defaultHyperdataFrame   (Just parentId)
 243 nodeDefault NodeFrameCalc    parentId = node NodeFrameCalc "Frame Calc"  defaultHyperdataFrame   (Just parentId)
 244 -- nodeDefault nt _ = panic $ "G.D.Q.T.Node.nodeDefault " <> (cs $ show nt)
 245
 246 ------------------------------------------------------------------------
 247 ------------------------------------------------------------------------
 248 node :: (ToJSON a, Hyperdata a)
 249      => NodeType
 250      -> Name
 251      -> a
 252      -> Maybe ParentId
 253      -> UserId
 254      -> NodeWrite
 255 node nodeType name hyperData parentId userId =
 256   Node Nothing
 257        (pgInt4 typeId)
 258        (pgInt4 userId)
 259        (pgNodeId <$> parentId)
 260        (pgStrictText name)
 261        Nothing
 262        (pgJSONB $ cs $ encode hyperData)
 263     where
 264       typeId = nodeTypeId nodeType
 265
 266                   -------------------------------
 267 insertNodes :: [NodeWrite] -> Cmd err Int64
 268 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 269
 270 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 271 insertNodesR ns = mkCmd $ \conn ->
 272   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
 273
 274 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 275 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
 276
 277 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 278 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 279 ------------------------------------------------------------------------
 280 -- TODO
 281 -- currently this function removes the child relation
 282 -- needs a Temporary type between Node' and NodeWriteT
 283
 284 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
 285 node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 286 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 287
 288
 289 data Node' = Node' { _n_type :: NodeType
 290                    , _n_name :: Text
 291                    , _n_data :: Value
 292                    , _n_children :: [Node']
 293                    } deriving (Show)
 294
 295 mkNodes :: [NodeWrite] -> Cmd err Int64
 296 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 297                    $ Insert nodeTable ns rCount Nothing
 298
 299 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 300 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 301
 302 ------------------------------------------------------------------------
 303 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 304 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 305 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 306 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 307
 308
 309 -- =================================================================== --
 310 -- |
 311 -- CorpusDocument is a corpus made from a set of documents
 312 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 313 data CorpusType = CorpusDocument | CorpusContact
 314
 315 class MkCorpus a
 316   where
 317     mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 318
 319 instance MkCorpus HyperdataCorpus
 320   where
 321     mk n h p u = insertNodesR [nodeCorpusW n h p u]
 322
 323
 324 instance MkCorpus HyperdataAnnuaire
 325   where
 326     mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
 327
 328
 329 getOrMkList :: HasNodeError err
 330             => ParentId
 331             -> UserId
 332             -> Cmd err ListId
 333 getOrMkList pId uId =
 334   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 335     where
 336       mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
 337
 338 mkList :: HasNodeError err
 339             => ParentId
 340             -> UserId
 341             -> Cmd err [ListId]
 342 mkList pId uId = mkNode NodeList pId uId
 343
 344 -- | TODO remove defaultList
 345 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 346 defaultList cId =
 347   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 348
 349 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 350 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 351
 352 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 353 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 354   where
 355     nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
 356     nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
 357       where
 358         name = maybe "Board" identity maybeName
 359         dashboard = maybe arbitraryDashboard identity maybeDashboard
 360         arbitraryDashboard :: HyperdataDashboard
 361         arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
 362
 363
 364 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 365 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 366
 367 -- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 368 -- updateNodeUser_fake :: NodeId -> Cmd err Int64
 369 -- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
 370