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