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