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