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
  13 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  14
  15 {-# LANGUAGE Arrows                 #-}
  16 {-# LANGUAGE ConstraintKinds        #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE QuasiQuotes       #-}
  19 {-# LANGUAGE TemplateHaskell        #-}
  20 {-# LANGUAGE TypeFamilies           #-}
  21
  22 module Gargantext.Database.Query.Table.Node
  23   where
  24
  25 import Control.Arrow (returnA)
  26 import Control.Lens (set, view)
  27 import Data.Aeson
  28 import Data.Maybe (fromMaybe)
  29 import Data.Text (Text)
  30 import qualified Database.PostgreSQL.Simple as DPS
  31 import Database.PostgreSQL.Simple.SqlQQ (sql)
  32 import Opaleye hiding (FromField)
  33 import Prelude hiding (null, id, map, sum)
  34
  35 import Gargantext.Core
  36 import Gargantext.Core.Types
  37 import Gargantext.Database.Admin.Types.Hyperdata
  38 import Gargantext.Database.Admin.Types.Hyperdata.Default
  39 import Gargantext.Database.Prelude
  40 import Gargantext.Database.Query.Filter (limit', offset')
  41 import Gargantext.Database.Query.Table.Node.Error
  42 import Gargantext.Database.Schema.Node
  43 import Gargantext.Prelude hiding (sum, head)
  44
  45
  46 queryNodeSearchTable :: Select NodeSearchRead
  47 queryNodeSearchTable = selectTable nodeTableSearch
  48
  49 selectNode :: Column SqlInt4 -> Select NodeRead
  50 selectNode id' = proc () -> do
  51     row      <- queryNodeTable -< ()
  52     restrict -< _node_id row .== id'
  53     returnA  -< row
  54
  55 runGetNodes :: Select NodeRead -> Cmd err [Node HyperdataAny]
  56 runGetNodes = runOpaQuery
  57
  58 ------------------------------------------------------------------------
  59 ------------------------------------------------------------------------
  60 -- | order by publication date
  61 -- Favorites (Bool), node_ngrams
  62 selectNodesWith :: HasDBid NodeType
  63                 => ParentId     -> Maybe NodeType
  64                 -> Maybe Offset -> Maybe Limit   -> Select 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' :: HasDBid NodeType
  72                  => ParentId -> Maybe NodeType -> Select NodeRead
  73 selectNodesWith' parentId maybeNodeType = proc () -> do
  74     node' <- (proc () -> do
  75       row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
  76       restrict -< parentId' .== (pgNodeId parentId)
  77
  78       let typeId' = maybe 0 toDBid maybeNodeType
  79
  80       restrict -< if typeId' > 0
  81                      then typeId   .== (sqlInt4 (typeId' :: Int))
  82                      else (sqlBool True)
  83       returnA  -< row ) -< ()
  84     returnA -< node'
  85
  86 deleteNode :: NodeId -> Cmd err Int
  87 deleteNode n = mkCmd $ \conn ->
  88   fromIntegral <$> runDelete_ conn
  89                  (Delete nodeTable
  90                          (\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgNodeId n)
  91                          rCount
  92                  )
  93
  94 deleteNodes :: [NodeId] -> Cmd err Int
  95 deleteNodes ns = mkCmd $ \conn ->
  96   fromIntegral <$> runDelete_ conn
  97                    (Delete nodeTable
  98                            (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
  99                            rCount
 100                    )
 101
 102 -- TODO: NodeType should match with `a'
 103 getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
 104              -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
 105 getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 106     runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
 107
 108 -- TODO: Why is the second parameter ignored?
 109 -- TODO: Why not use getNodesWith?
 110 getNodesWithParentId :: (Hyperdata a, JSONB a)
 111                      => Maybe NodeId
 112                      -> Cmd err [Node a]
 113 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
 114   where
 115     n' = case n of
 116       Just n'' -> n''
 117       Nothing  -> 0
 118
 119
 120 -- | Given a node id, find it's closest parent of given type
 121 -- NOTE: This isn't too optimal: can make successive queries depending on how
 122 -- deeply nested the child is.
 123 getClosestParentIdByType :: HasDBid NodeType
 124                          => NodeId
 125                          -> NodeType
 126                          -> Cmd err (Maybe NodeId)
 127 getClosestParentIdByType nId nType = do
 128   result <- runPGSQuery query (nId, 0 :: Int)
 129   case result of
 130     [(NodeId parentId, pTypename)] -> do
 131       if toDBid nType == pTypename then
 132         pure $ Just $ NodeId parentId
 133       else
 134         getClosestParentIdByType (NodeId parentId) nType
 135     _ -> pure Nothing
 136   where
 137     query :: DPS.Query
 138     query = [sql|
 139       SELECT n2.id, n2.typename
 140       FROM nodes n1
 141         JOIN nodes n2 ON n1.parent_id = n2.id
 142         WHERE n1.id = ? AND 0 = ?;
 143     |]
 144
 145 -- | Similar to `getClosestParentIdByType` but includes current node
 146 -- in search too
 147 getClosestParentIdByType' :: HasDBid NodeType
 148                           => NodeId
 149                           -> NodeType
 150                           -> Cmd err (Maybe NodeId)
 151 getClosestParentIdByType' nId nType = do
 152   result <- runPGSQuery query (nId, 0 :: Int)
 153   case result of
 154     [(NodeId id, pTypename)] -> do
 155       if toDBid nType == pTypename then
 156         pure $ Just $ NodeId id
 157       else
 158         getClosestParentIdByType nId nType
 159     _ -> pure Nothing
 160   where
 161     query :: DPS.Query
 162     query = [sql|
 163       SELECT n.id, n.typename
 164       FROM nodes n
 165       WHERE n.id = ? AND 0 = ?;
 166     |]
 167
 168 -- | Given a node id, find all it's children (no matter how deep) of
 169 -- given node type.
 170 getChildrenByType :: HasDBid NodeType
 171                   => NodeId
 172                   -> NodeType
 173                   -> Cmd err [NodeId]
 174 getChildrenByType nId nType = do
 175   result <- runPGSQuery query (nId, 0 :: Int)
 176   children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
 177   pure $ concat $ [fst <$> filter (\(_, pTypename) -> pTypename == toDBid nType) result] ++ children_lst
 178   where
 179     query :: DPS.Query
 180     query = [sql|
 181       SELECT n.id, n.typename
 182       FROM nodes n
 183       WHERE n.parent_id = ? AND 0 = ?;
 184     |]
 185
 186 ------------------------------------------------------------------------
 187 getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
 188 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 189
 190 -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
 191 getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
 192 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 193
 194 getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
 195 getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 196
 197 getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
 198 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 199
 200 ------------------------------------------------------------------------
 201 selectNodesWithParentID :: NodeId -> Select NodeRead
 202 selectNodesWithParentID n = proc () -> do
 203     row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 204     restrict -< parent_id .== (pgNodeId n)
 205     returnA -< row
 206
 207
 208 ------------------------------------------------------------------------
 209 -- | Example of use:
 210 -- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
 211 getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
 212 getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
 213   where
 214     selectNodesWithType ::  HasDBid NodeType
 215                          => NodeType -> Select NodeRead
 216     selectNodesWithType nt' = proc () -> do
 217         row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 218         restrict -< tn .== (sqlInt4 $ toDBid nt')
 219         returnA -< row
 220
 221 getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
 222 getNodesIdWithType nt = do
 223   ns <- runOpaQuery $ selectNodesIdWithType nt
 224   pure (map NodeId ns)
 225
 226 selectNodesIdWithType :: HasDBid NodeType
 227                       => NodeType -> Select (Column SqlInt4)
 228 selectNodesIdWithType nt = proc () -> do
 229     row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
 230     restrict -< tn .== (sqlInt4 $ toDBid nt)
 231     returnA -< _node_id row
 232
 233 ------------------------------------------------------------------------
 234
 235
 236 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
 237 getNode nId = do
 238   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 239   case maybeNode of
 240     Nothing -> nodeError (DoesNotExist nId)
 241     Just  r -> pure r
 242
 243 getNodeWith :: (HasNodeError err, JSONB a)
 244             => NodeId -> proxy a -> Cmd err (Node a)
 245 getNodeWith nId _ = do
 246   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
 247   case maybeNode of
 248     Nothing -> nodeError (DoesNotExist nId)
 249     Just  r -> pure r
 250
 251
 252 ------------------------------------------------------------------------
 253 -- | Sugar to insert Node with NodeType in Database
 254 insertDefaultNode :: HasDBid NodeType
 255                   => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 256 insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 257
 258 insertDefaultNodeIfNotExists :: HasDBid NodeType
 259                              => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 260 insertDefaultNodeIfNotExists nt p u = do
 261   children <- getChildrenByType p nt
 262   case children of
 263     [] -> insertDefaultNode nt p u
 264     xs -> pure xs
 265
 266 insertNode :: HasDBid NodeType
 267            => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
 268 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 269
 270 nodeW ::  HasDBid NodeType
 271        => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
 272 nodeW nt n h p u = node nt n' h' (Just p) u
 273   where
 274     n' = fromMaybe (defaultName nt) n
 275     h' = maybe     (defaultHyperdata nt) identity h
 276
 277 ------------------------------------------------------------------------
 278 node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
 279      => NodeType
 280      -> Name
 281      -> a
 282      -> Maybe ParentId
 283      -> UserId
 284      -> NodeWrite
 285 node nodeType name hyperData parentId userId =
 286   Node Nothing Nothing
 287        (sqlInt4 typeId)
 288        (sqlInt4 userId)
 289        (pgNodeId <$> parentId)
 290        (sqlStrictText name)
 291        Nothing
 292        (sqlJSONB $ cs $ encode hyperData)
 293     where
 294       typeId = toDBid nodeType
 295
 296                   -------------------------------
 297 insertNodes :: [NodeWrite] -> Cmd err Int64
 298 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 299
 300 {-
 301 insertNodes' :: [Node a] -> Cmd err Int64
 302 insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
 303                         $ Insert nodeTable ns' rCount Nothing
 304   where
 305     ns' :: [NodeWrite]
 306     ns' = map (\(Node i t u p n d h)
 307                 -> Node (pgNodeId          <$> i)
 308                         (sqlInt4 $ toDBid      t)
 309                         (sqlInt4                u)
 310                         (pgNodeId          <$> p)
 311                         (sqlStrictText          n)
 312                         (pgUTCTime         <$> d)
 313                         (pgJSONB $ cs $ encode h)
 314               ) ns
 315 -}
 316
 317 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 318 insertNodesR ns = mkCmd $ \conn ->
 319   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 320
 321 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 322 insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 323
 324 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 325 insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 326 ------------------------------------------------------------------------
 327 -- TODO
 328 -- currently this function removes the child relation
 329 -- needs a Temporary type between Node' and NodeWriteT
 330
 331 node2table :: HasDBid NodeType
 332            => UserId -> Maybe ParentId -> Node' -> NodeWrite
 333 node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (sqlInt4 $ toDBid nt) (sqlInt4 uid) (fmap pgNodeId pid) (sqlStrictText txt) Nothing (sqlStrictJSONB $ cs $ encode v)
 334 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 335
 336
 337 data Node' = Node' { _n_type :: NodeType
 338                    , _n_name :: Text
 339                    , _n_data :: Value
 340                    , _n_children :: [Node']
 341                    } deriving (Show)
 342
 343 mkNodes :: [NodeWrite] -> Cmd err Int64
 344 mkNodes ns = mkCmd $ \conn -> runInsert_ conn
 345                    $ Insert nodeTable ns rCount Nothing
 346
 347 mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 348 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 349
 350 ------------------------------------------------------------------------
 351 childWith ::  HasDBid NodeType
 352            => UserId -> ParentId -> Node' -> NodeWrite
 353 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 354 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 355 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 356
 357
 358 -- =================================================================== --
 359 -- |
 360 -- CorpusDocument is a corpus made from a set of documents
 361 -- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
 362 data CorpusType = CorpusDocument | CorpusContact
 363
 364 class MkCorpus a
 365   where
 366     mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
 367
 368 instance MkCorpus HyperdataCorpus
 369   where
 370     mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
 371     mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 372
 373
 374 instance MkCorpus HyperdataAnnuaire
 375   where
 376     mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
 377     mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 378
 379
 380 getOrMkList :: (HasNodeError err, HasDBid NodeType)
 381             => ParentId
 382             -> UserId
 383             -> Cmd err ListId
 384 getOrMkList pId uId =
 385   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
 386     where
 387       mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
 388
 389 -- | TODO remove defaultList
 390 defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
 391 defaultList cId =
 392   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 393
 394 defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
 395 defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
 396
 397 getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
 398 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 399