NodeNode.hs

{-| Module      : Gargantext.Database.Select.Table.NodeNode
Description :
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

Here is a longer description of this module, containing some
commentary with @some markup@.
-}

{-# LANGUAGE Arrows                 #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE QuasiQuotes            #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}

module Gargantext.Database.Query.Table.NodeNode
  ( module Gargantext.Database.Schema.NodeNode

  -- * Types
  , SourceId(..)
  , TargetId(..)
  , OwnerId(..)
  , PublishedNodeInfo(..)

  -- * Queries
  , getNodeNode
  , getNodeNode2
  , isNodeReadOnly
  , selectDocNodes
  , selectDocs
  , selectDocsDates
  , selectPublicNodes
  , selectPublishedNodes

  -- * Destructive operations
  , deleteNodeNode
  , nodeNodesCategory
  , nodeNodesScore
  , pairCorpusWithAnnuaire
  , publishNode
  , unpublishNode
  , queryNodeNodeTable
  , shareNode

  -- * Internals (use with caution)
  , insertNodeNode
  )
  where

import Control.Arrow (returnA)
import Control.Lens (view)
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..), Only (..))
import Data.Text (splitOn)
import Gargantext.Core ( HasDBid(toDBid) )
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument, hd_publication_date )
import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( Hyperdata )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Schema.Ngrams ()
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNode
import Gargantext.Prelude
import Opaleye
import Opaleye qualified as O
import qualified Control.Lens as L

queryNodeNodeTable :: Select NodeNodeRead
queryNodeNodeTable = selectTable nodeNodeTable

-- | not optimized (get all ngrams without filters)
_nodesNodes :: DBQuery err x [NodeNode]
_nodesNodes = mkOpaQuery queryNodeNodeTable

------------------------------------------------------------------------
-- | Basic NodeNode tools
getNodeNode :: NodeId -> DBQuery err x [NodeNode]
getNodeNode n = mkOpaQuery (selectNodeNode $ pgNodeId n)
  where
    selectNodeNode :: Column SqlInt4 -> Select NodeNodeRead
    selectNodeNode n' = proc () -> do
      ns <- queryNodeNodeTable -< ()
      restrict -< _nn_node1_id ns .== n'
      returnA -< ns

getNodeNode2 :: NodeId -> DBQuery err x (Maybe NodeNode)
getNodeNode2 n = listToMaybe <$> mkOpaQuery (selectNodeNode $ pgNodeId n)
  where
    selectNodeNode :: Column SqlInt4 -> Select NodeNodeRead
    selectNodeNode n' = proc () -> do
      ns <- queryNodeNodeTable -< ()
      restrict -< _nn_node2_id ns .== n'
      returnA -< ns

------------------------------------------------------------------------
-- TODO (refactor with Children)
{-
getNodeNodeWith :: NodeId -> proxy a -> Maybe NodeType -> DBCmd err [a]
getNodeNodeWith pId _ maybeNodeType = mkOpaQuery query
  where
    query = selectChildren pId maybeNodeType

    selectChildren :: ParentId
                   -> Maybe NodeType
                   -> Select NodeRead
    selectChildren parentId maybeNodeType = proc () -> do
        row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
        (NodeNode _ n1id n2id _ _) <- queryNodeNodeTable -< ()

        let nodeType = maybe 0 toDBid maybeNodeType
        restrict -< typeName  .== sqlInt4 nodeType

        restrict -< (.||) (parent_id .== (pgNodeId parentId))
                          ( (.&&) (n1id .== pgNodeId parentId)
                                  (n2id .== nId))
        returnA -< row
-}

------------------------------------------------------------------------
-- | Inserts a list of 'NodeNode', creating relationship between nodes
-- in the database. This function is deliberately not exposed, because
-- it's low-level and it doesn't do any business-logic check to ensure
-- the share being created is valid. Use the other functions like
-- 'shareNode', 'publishNode', or roll your own.
insertNodeNode :: [NodeNode] -> DBUpdate err Int
insertNodeNode ns = fromIntegral <$> (mkOpaInsert $ Insert nodeNodeTable ns' rCount (Just doNothing))
  where
    ns' :: [NodeNodeWrite]
    ns' = map (\(NodeNode n1 n2 x y)
                -> NodeNode (pgNodeId n1)
                            (pgNodeId n2)
                            (sqlDouble <$> x)
                            (sqlInt4 . toDBid <$> y)
              ) ns



------------------------------------------------------------------------
type Node1_Id = NodeId
type Node2_Id = NodeId

deleteNodeNode :: Node1_Id -> Node2_Id -> DBUpdate err Int
deleteNodeNode n1 n2 =
  fromIntegral <$> mkOpaDelete
                  (Delete nodeNodeTable
                          (\(NodeNode n1_id n2_id _ _) -> n1_id .== pgNodeId n1
                                                      .&& n2_id .== pgNodeId n2
                          )
                          rCount
                  )

------------------------------------------------------------------------
-- | Favorite management
_nodeNodeCategory :: CorpusId -> DocId -> Int -> DBUpdate err [Int]
_nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> mkPGUpdateReturningMany favQuery (c,cId,dId)
  where
    favQuery :: PGS.Query
    favQuery = [sql|UPDATE nodes_nodes SET category = ?
               WHERE node1_id = ? AND node2_id = ?
               RETURNING node2_id;
               |]

nodeNodesCategory :: [(CorpusId, DocId, Int)] -> DBQuery err x [Int]
nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
                            <$> mkPGQuery catQuery (PGS.Only $ Values fields inputData)
  where
    fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
    catQuery :: PGS.Query
    catQuery = [sql| UPDATE nodes_nodes as nn0
                      SET category = nn1.category
                       FROM (?) as nn1(node1_id,node2_id,category)
                       WHERE nn0.node1_id = nn1.node1_id
                       AND   nn0.node2_id = nn1.node2_id
                       RETURNING nn1.node2_id
                  |]

------------------------------------------------------------------------
-- | Score management
_nodeNodeScore :: CorpusId -> DocId -> Int -> DBQuery err x [Int]
_nodeNodeScore cId dId c = map (\(PGS.Only a) -> a) <$> mkPGQuery scoreQuery (c,cId,dId)
  where
    scoreQuery :: PGS.Query
    scoreQuery = [sql|UPDATE nodes_nodes SET score = ?
                  WHERE node1_id = ? AND node2_id = ?
                  RETURNING node2_id;
                  |]

nodeNodesScore :: [(CorpusId, DocId, Int)] -> DBQuery err x [Int]
nodeNodesScore inputData = map (\(PGS.Only a) -> a)
                            <$> mkPGQuery catScore (PGS.Only $ Values fields inputData)
  where
    fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
    catScore :: PGS.Query
    catScore = [sql| UPDATE nodes_nodes as nn0
                      SET score = nn1.score
                       FROM (?) as nn1(node1_id, node2_id, score)
                       WHERE nn0.node1_id = nn1.node1_id
                       AND   nn0.node2_id = nn1.node2_id
                       RETURNING nn1.node2_id
                  |]

------------------------------------------------------------------------
_selectCountDocs :: HasDBid NodeType => CorpusId -> DBQuery err x Int
_selectCountDocs cId = mkOpaCountQuery (queryCountDocs cId)
  where
    queryCountDocs cId' = proc () -> do
      (n, nn) <- joinInCorpus -< ()
      restrict -< matchMaybe nn $ \case
        Nothing  -> toFields True
        Just nn' -> (nn' ^. nn_node1_id) .== pgNodeId cId' .&&
                    (nn' ^. nn_category) .>= sqlInt4 1
      restrict -< n^.node_typename .== sqlInt4 (toDBid NodeDocument)
      returnA -< n




-- | TODO use UTCTime fast
selectDocsDates :: HasDBid NodeType => CorpusId -> DBQuery err x [Text]
selectDocsDates cId =  map (head' "selectDocsDates" . splitOn "-")
                   <$> catMaybes
                   <$> map (view hd_publication_date)
                   <$> selectDocs cId

selectDocs :: HasDBid NodeType => CorpusId -> DBQuery err x [HyperdataDocument]
selectDocs cId = mkOpaQuery (queryDocs cId)

queryDocs :: HasDBid NodeType => CorpusId -> O.Select (Column SqlJsonb)
queryDocs cId = proc () -> do
  (n, nn) <- joinInCorpus -< ()
  restrict -< matchMaybe nn $ \case
    Nothing  -> toFields True
    Just nn' -> (nn' ^. nn_node1_id) .== pgNodeId cId .&&
                (nn' ^. nn_category) .>= sqlInt4 1
  restrict -< n ^. node_typename .== (sqlInt4 $ toDBid NodeDocument)
  returnA -< view node_hyperdata n

selectDocNodes :: HasDBid NodeType => CorpusId -> DBQuery err x [Node HyperdataDocument]
selectDocNodes cId = mkOpaQuery (queryDocNodes cId)

queryDocNodes :: HasDBid NodeType =>CorpusId -> O.Select NodeRead
queryDocNodes cId = proc () -> do
  (n, nn) <- joinInCorpus -< ()
  restrict -< matchMaybe nn $ \case
    Nothing  -> toFields True
    Just nn' -> (nn' ^.nn_node1_id   .== pgNodeId cId) .&&
                (nn' ^. nn_category) .>= sqlInt4 1
  restrict -< n^.node_typename .== sqlInt4 (toDBid NodeDocument)
  returnA -<  n

joinInCorpus :: O.Select (NodeRead, MaybeFields NodeNodeRead)
joinInCorpus = proc () -> do
  n <- queryNodeTable -< ()
  nn <- optionalRestrict queryNodeNodeTable -<
        (\nn' -> (nn' ^. nn_node2_id) .== view node_id n)
  returnA -< (n, nn)


------------------------------------------------------------------------
-- | Returns /all/ the public nodes, i.e. nodes which 'NodeType' is
-- 'NodeFolderPublic'. Each user, upon creation, receives his/her personal
-- public folder. Nodes placed inside /any/ public folder is visible into
-- /any other/ public folder.
selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
                  => DBQuery err x [(Node a, Maybe Int)]
selectPublicNodes = mkOpaQuery (queryWithType NodeFolderPublic)

data PublishedNodeInfo
  = PublishedNodeInfo
  { pni_source_id :: !SourceId
  , pni_target_id :: !TargetId
  , pni_owner_id  :: !OwnerId
  , pni_policy    :: !NodePublishPolicy
  } deriving (Show, Eq)

selectPublishedNodes :: DBQuery err x [PublishedNodeInfo]
selectPublishedNodes =
  mapMaybe mk_info <$> published_node_ids []
  where
    mk_info :: (NodeId, NodeNode) -> Maybe PublishedNodeInfo
    mk_info (owner, nn) =
      PublishedNodeInfo <$> (pure $ SourceId $ _nn_node2_id nn)
                        <*> (pure $ TargetId $ _nn_node1_id nn)
                        <*> (pure $ OwnerId  owner)
                        <*> (nn L.^? (nn_category . L._Just . _NNC_publish))

published_node_ids :: [ NodeNodeRead -> Field SqlBool ] -> DBQuery err x [(NodeId, NodeNode)]
published_node_ids extraPreds = mkOpaQuery $ do
  n  <- queryNodeTable
  nn <- queryNodeNodeTable
  let isRO = ors [ (nn ^. nn_category .== sqlInt4 (toDBid $ NNC_publish ro))
                 | ro <- [minBound .. maxBound]
                 ]
  where_ isRO
  where_ $ (n ^. node_id .== nn ^. nn_node1_id)
  where_ $ ands (map ($ nn) extraPreds)
  pure (n ^. node_parent_id, nn)
  where

ands :: Foldable f => f (Field SqlBool) -> Field SqlBool
ands = foldl' (.&&) (sqlBool True)

-- | A 'Node' is read-only if there exist a match in the node_nodes directory
-- where the source is a public folder. Certain category of nodes (like private/shared folders, etc)
-- are automatically read-only.
isNodeReadOnly :: (HasNodeError err, HasDBid NodeType) => NodeId -> DBQuery err x Bool
isNodeReadOnly targetNodeId = do
  targetNode <- getNode targetNodeId
  case targetNode ^. node_typename `elem` map toDBid typesWhiteList of
    True  -> pure True
    False -> is_read_only_query
  where
    -- Certain kind of nodes are by default read-only and can in principle be visualised by other users
    -- without harm. This would be the case for a user node which might contained published corpuses.
    typesWhiteList :: [ NodeType ]
    typesWhiteList = [ NodeFolderPublic ]

    is_read_only_query = (== [Only True])
      <$> mkPGQuery [sql|
          WITH RECURSIVE ParentNodes AS (
            -- Base case: Start from the given node ID
            SELECT id, parent_id
            FROM nodes
            WHERE id = ?

            UNION ALL

            -- Recursive case: Traverse to parent nodes
            SELECT n.id, n.parent_id
            FROM nodes n
            JOIN ParentNodes pn ON n.id = pn.parent_id
        )
        SELECT EXISTS (
            SELECT 1
            FROM ParentNodes pn
            JOIN nodes_nodes nn ON pn.id = nn.node1_id OR pn.id = nn.node2_id
            JOIN nodes n ON (nn.node1_id = n.id OR nn.node2_id = n.id)
            WHERE n.typename = ? AND nn.category <= ?
        ) OR EXISTS (
               SELECT 1
               FROM nodes
               WHERE id = ? AND typename = ? -- if the target is a public folder, it's automatically considered read-only
        ) AS is_read_only;

      |] ( targetNodeId
         , toDBid NodeFolderPublic
         , toDBid (maxBound @NodePublishPolicy)
         , targetNodeId
         , toDBid NodeFolderPublic
         )


queryWithType :: HasDBid NodeType
              => NodeType
              -> O.Select (NodeRead, MaybeFields (Column SqlInt4))
queryWithType nt = proc () -> do
  (n, nn_node2_id') <- node_NodeNode -< ()
  restrict -< n^.node_typename .== sqlInt4 (toDBid nt)
  returnA  -<  (n, nn_node2_id')

node_NodeNode :: O.Select (NodeRead, MaybeFields (Field SqlInt4))
node_NodeNode = proc () -> do
  n <- queryNodeTable -< ()
  nn <- optionalRestrict queryNodeNodeTable -<
    (\nn' -> (nn' ^. nn_node1_id) .== (n ^. node_id))
  returnA -< (n, view nn_node2_id <$> nn)

newtype SourceId = SourceId { _SourceId :: NodeId }
  deriving (Show, Eq, Ord)
newtype TargetId = TargetId { _TargetId :: NodeId }
  deriving (Show, Eq, Ord)
newtype OwnerId = OwnerId { _OwnerId :: NodeId }
  deriving (Show, Eq, Ord)

shareNode :: SourceId -> TargetId -> DBUpdate err Int
shareNode (SourceId sourceId) (TargetId targetId) =
  insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]

-- | Publishes a node, i.e. it creates a relationship between
-- the input node and the target public folder.
-- /NOTE/: Even though the semantic of the relationships it
-- source -> target, by historical reason we store this in the
-- node_node table backwards, i.e. the public folder first as
-- the 'node1_id', and the shared node as the target, so we
-- honour this.
publishNode :: NodePublishPolicy -> SourceId -> TargetId -> DBUpdate err ()
publishNode publishPolicy (SourceId sourceId) (TargetId targetId) =
  void $ insertNodeNode [ NodeNode targetId sourceId Nothing (Just $ NNC_publish publishPolicy) ]

-- /NOTE/: Even though the semantic of the relationships it
-- source -> target, by historical reason we store this in the
-- node_node table backwards, i.e. the public folder first as
-- the 'node1_id', and the shared node as the target, so we
-- honour this.
unpublishNode :: SourceId -> TargetId -> DBUpdate err ()
unpublishNode (SourceId sourceId) (TargetId targetId) =
  void $ deleteNodeNode targetId sourceId

-- | Pair two nodes together. Typically used to pair
-- together
pairCorpusWithAnnuaire :: SourceId -> TargetId -> DBUpdate err ()
pairCorpusWithAnnuaire (SourceId sourceId) (TargetId targetId) =
  void $ insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]