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