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