src/Gargantext/Database/Schema/NodeNode.hs

   1 {-|
   2 Module      : Gargantext.Database.Schema.NodeNode
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 {-# LANGUAGE Arrows                 #-}
  17 {-# LANGUAGE FlexibleContexts       #-}
  18 {-# LANGUAGE FlexibleInstances      #-}
  19 {-# LANGUAGE FunctionalDependencies #-}
  20 {-# LANGUAGE QuasiQuotes            #-}
  21 {-# LANGUAGE MultiParamTypeClasses  #-}
  22 {-# LANGUAGE NoImplicitPrelude      #-}
  23 {-# LANGUAGE OverloadedStrings      #-}
  24 {-# LANGUAGE RankNTypes             #-}
  25 {-# LANGUAGE TemplateHaskell        #-}
  26
  27 module Gargantext.Database.Schema.NodeNode where
  28
  29 import Control.Arrow (returnA)
  30 import Control.Lens (view, (^.))
  31 import Control.Lens.TH (makeLenses)
  32 import Data.Maybe (Maybe, catMaybes)
  33 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  34 import Data.Text (Text, splitOn)
  35 import Database.PostgreSQL.Simple.SqlQQ (sql)
  36 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  37 import Gargantext.Core.Types
  38 import Gargantext.Database.Admin.Types.Node (pgNodeId)
  39 import Gargantext.Database.Admin.Config (nodeTypeId)
  40 import Gargantext.Database.Admin.Types.Node (CorpusId, DocId)
  41 import Gargantext.Database.Admin.Utils
  42 import Gargantext.Database.Schema.Node
  43 import Gargantext.Prelude
  44 import Opaleye
  45 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
  46 import qualified Opaleye as O
  47
  48 data NodeNodePoly node1_id node2_id score cat
  49                    = NodeNode { _nn_node1_id   :: node1_id
  50                               , _nn_node2_id   :: node2_id
  51                               , _nn_score      :: score
  52                               , _nn_category   :: cat
  53                               } deriving (Show)
  54
  55 type NodeNodeWrite     = NodeNodePoly (Column (PGInt4))
  56                                       (Column (PGInt4))
  57                                       (Maybe  (Column (PGFloat8)))
  58                                       (Maybe  (Column (PGInt4)))
  59
  60 type NodeNodeRead      = NodeNodePoly (Column (PGInt4))
  61                                       (Column (PGInt4))
  62                                       (Column (PGFloat8))
  63                                       (Column (PGInt4))
  64
  65 type NodeNodeReadNull  = NodeNodePoly (Column (Nullable PGInt4))
  66                                       (Column (Nullable PGInt4))
  67                                       (Column (Nullable PGFloat8))
  68                                       (Column (Nullable PGInt4))
  69
  70 type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe Int)
  71
  72 $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
  73 makeLenses ''NodeNodePoly
  74
  75 nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
  76 nodeNodeTable  = Table "nodes_nodes" (pNodeNode
  77                                 NodeNode { _nn_node1_id = required "node1_id"
  78                                          , _nn_node2_id = required "node2_id"
  79                                          , _nn_score    = optional "score"
  80                                          , _nn_category = optional "category"
  81                                      }
  82                                      )
  83
  84 queryNodeNodeTable :: Query NodeNodeRead
  85 queryNodeNodeTable = queryTable nodeNodeTable
  86
  87
  88 -- | not optimized (get all ngrams without filters)
  89 nodesNodes :: Cmd err [NodeNode]
  90 nodesNodes = runOpaQuery queryNodeNodeTable
  91
  92 instance QueryRunnerColumnDefault (Nullable PGInt4) Int where
  93     queryRunnerColumnDefault = fieldQueryRunnerColumn
  94
  95 instance QueryRunnerColumnDefault (Nullable PGFloat8) Int where
  96     queryRunnerColumnDefault = fieldQueryRunnerColumn
  97
  98 instance QueryRunnerColumnDefault (Nullable PGFloat8) Double where
  99     queryRunnerColumnDefault = fieldQueryRunnerColumn
 100
 101 instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
 102     queryRunnerColumnDefault = fieldQueryRunnerColumn
 103
 104 instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
 105     queryRunnerColumnDefault = fieldQueryRunnerColumn
 106
 107 ------------------------------------------------------------------------
 108 -- | Basic NodeNode tools
 109 getNodeNode :: NodeId -> Cmd err [NodeNode]
 110 getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
 111   where
 112     selectNodeNode :: Column PGInt4 -> Query NodeNodeRead
 113     selectNodeNode n' = proc () -> do
 114       ns <- queryNodeNodeTable -< ()
 115       restrict -< _nn_node1_id ns .== n'
 116       returnA -< ns
 117
 118 -------------------------
 119 insertNodeNode :: [NodeNode] -> Cmd err Int64
 120 insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeNodeTable ns' rCount Nothing
 121   where
 122     ns' :: [NodeNodeWrite]
 123     ns' = map (\(NodeNode n1 n2 x y)
 124                 -> NodeNode (pgNodeId n1)
 125                             (pgNodeId n2)
 126                             (pgDouble <$> x)
 127                             (pgInt4   <$> y)
 128               ) ns
 129
 130
 131 -- | Favorite management
 132 nodeNodeCategory :: CorpusId -> DocId -> Int -> Cmd err [Int]
 133 nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (c,cId,dId)
 134   where
 135     favQuery :: PGS.Query
 136     favQuery = [sql|UPDATE nodes_nodes SET category = ?
 137                WHERE node1_id = ? AND node2_id = ?
 138                RETURNING node2_id;
 139                |]
 140
 141 nodeNodesCategory :: [(CorpusId,DocId,Int)] -> Cmd err [Int]
 142 nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
 143                             <$> runPGSQuery catQuery (PGS.Only $ Values fields inputData)
 144   where
 145     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","int4"]
 146     catQuery :: PGS.Query
 147     catQuery = [sql| UPDATE nodes_nodes as nn0
 148                       SET category = nn1.category
 149                        FROM (?) as nn1(node1_id,node2_id,category)
 150                        WHERE nn0.node1_id = nn1.node1_id
 151                        AND   nn0.node2_id = nn1.node2_id
 152                        RETURNING nn1.node2_id
 153                   |]
 154
 155 ------------------------------------------------------------------------
 156 -- | TODO use UTCTime fast
 157 selectDocsDates :: CorpusId -> Cmd err [Text]
 158 selectDocsDates cId =  map (head' "selectDocsDates" . splitOn "-")
 159                    <$> catMaybes
 160                    <$> map (view hyperdataDocument_publication_date)
 161                    <$> selectDocs cId
 162
 163 selectDocs :: CorpusId -> Cmd err [HyperdataDocument]
 164 selectDocs cId = runOpaQuery (queryDocs cId)
 165
 166 queryDocs :: CorpusId -> O.Query (Column PGJsonb)
 167 queryDocs cId = proc () -> do
 168   (n, nn) <- joinInCorpus -< ()
 169   restrict -< nn^.nn_node1_id  .== (toNullable $ pgNodeId cId)
 170   restrict -< nn^.nn_category  .>= (toNullable $ pgInt4 1)
 171   restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
 172   returnA -< view (node_hyperdata) n
 173
 174 selectDocNodes :: CorpusId -> Cmd err [Node HyperdataDocument]
 175 selectDocNodes cId = runOpaQuery (queryDocNodes cId)
 176
 177 queryDocNodes :: CorpusId -> O.Query NodeRead
 178 queryDocNodes cId = proc () -> do
 179   (n, nn) <- joinInCorpus -< ()
 180   restrict -< nn^.nn_node1_id  .== (toNullable $ pgNodeId cId)
 181   restrict -< nn^.nn_category  .>= (toNullable $ pgInt4 1)
 182   restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
 183   returnA -<  n
 184
 185 joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
 186 joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
 187   where
 188     cond :: (NodeRead, NodeNodeRead) -> Column PGBool
 189     cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
 190
 191 ------------------------------------------------------------------------
 192 -- | Trash management
 193 nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
 194 nodeToTrash cId dId b = runPGSQuery trashQuery (b,cId,dId)
 195   where
 196     trashQuery :: PGS.Query
 197     trashQuery = [sql|UPDATE nodes_nodes SET delete = ?
 198                   WHERE node1_id = ? AND node2_id = ?
 199                   RETURNING node2_id
 200                   |]
 201
 202 -- | Trash Massive
 203 nodesToTrash :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
 204 nodesToTrash input = map (\(PGS.Only a) -> a)
 205                         <$> runPGSQuery trashQuery (PGS.Only $ Values fields input)
 206   where
 207     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
 208     trashQuery :: PGS.Query
 209     trashQuery = [sql| UPDATE nodes_nodes as nn0 SET
 210                  delete = nn1.delete
 211                  from (?) as nn1(node1_id,node2_id,delete)
 212                  WHERE nn0.node1_id = nn1.node1_id
 213                  AND   nn0.node2_id = nn1.node2_id
 214                  RETURNING nn1.node2_id
 215                   |]
 216
 217 -- | /!\ Really remove nodes in the Corpus or Annuaire
 218 emptyTrash :: CorpusId -> Cmd err [PGS.Only Int]
 219 emptyTrash cId = runPGSQuery delQuery (PGS.Only cId)
 220   where
 221     delQuery :: PGS.Query
 222     delQuery = [sql|DELETE from nodes_nodes n
 223                     WHERE n.node1_id = ?
 224                       AND n.delete = true
 225                     RETURNING n.node2_id
 226                 |]
 227 ------------------------------------------------------------------------