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 (makeLensesWith, abbreviatedFields)
  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 Int Int (Maybe Double) (Maybe Int)
  69
  70 $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
  71 $(makeLensesWith abbreviatedFields   ''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 PGFloat8 (Maybe Double) where
  94     queryRunnerColumnDefault = fieldQueryRunnerColumn
  95
  96 instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
  97     queryRunnerColumnDefault = fieldQueryRunnerColumn
  98
  99
 100 ------------------------------------------------------------------------
 101 -- | Favorite management
 102 nodeNodeCategory :: CorpusId -> DocId -> Int -> Cmd err [Int]
 103 nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (c,cId,dId)
 104   where
 105     favQuery :: PGS.Query
 106     favQuery = [sql|UPDATE nodes_nodes SET category = ?
 107                WHERE node1_id = ? AND node2_id = ?
 108                RETURNING node2_id;
 109                |]
 110
 111 nodeNodesCategory :: [(CorpusId,DocId,Int)] -> Cmd err [Int]
 112 nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
 113                             <$> runPGSQuery catQuery (PGS.Only $ Values fields inputData)
 114   where
 115     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","int4"]
 116     catQuery :: PGS.Query
 117     catQuery = [sql| UPDATE nodes_nodes as old SET
 118                  category = new.category
 119                  from (?) as new(node1_id,node2_id,category)
 120                  WHERE old.node1_id = new.node1_id
 121                  AND   old.node2_id = new.node2_id
 122                  RETURNING new.node2_id
 123                   |]
 124
 125 ------------------------------------------------------------------------
 126 -- | TODO use UTCTime fast
 127 selectDocsDates :: CorpusId -> Cmd err [Text]
 128 selectDocsDates cId =
 129                 map (head' "selectDocsDates" . splitOn "-")
 130                <$> catMaybes
 131                <$> map (view hyperdataDocument_publication_date)
 132                <$> selectDocs cId
 133
 134
 135 selectDocs :: CorpusId -> Cmd err [HyperdataDocument]
 136 selectDocs cId = runOpaQuery (queryDocs cId)
 137
 138 queryDocs :: CorpusId -> O.Query (Column PGJsonb)
 139 queryDocs cId = proc () -> do
 140   (n, nn) <- joinInCorpus -< ()
 141   restrict -< ( nn_node1_id nn)  .== (toNullable $ pgNodeId cId)
 142   restrict -< ( nn_category nn)  .>= (toNullable $ pgInt4 1)
 143   restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
 144   returnA -< view (node_hyperdata) n
 145
 146
 147 selectDocNodes :: CorpusId -> Cmd err [NodeDocument]
 148 selectDocNodes cId = runOpaQuery (queryDocNodes cId)
 149
 150 queryDocNodes :: CorpusId -> O.Query NodeRead
 151 queryDocNodes cId = proc () -> do
 152   (n, nn) <- joinInCorpus -< ()
 153   restrict -< ( nn_node1_id nn)  .== (toNullable $ pgNodeId cId)
 154   restrict -< ( nn_category nn)  .>= (toNullable $ pgInt4 1)
 155   restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
 156   returnA -<  n
 157
 158
 159
 160 joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
 161 joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
 162   where
 163     cond :: (NodeRead, NodeNodeRead) -> Column PGBool
 164     cond (n, nn) = nn_node2_id nn .== (view node_id n)
 165
 166
 167 ------------------------------------------------------------------------
 168 -- | Trash management
 169 nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
 170 nodeToTrash cId dId b = runPGSQuery trashQuery (b,cId,dId)
 171   where
 172     trashQuery :: PGS.Query
 173     trashQuery = [sql|UPDATE nodes_nodes SET delete = ?
 174                   WHERE node1_id = ? AND node2_id = ?
 175                   RETURNING node2_id
 176                   |]
 177
 178 -- | Trash Massive
 179 nodesToTrash :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
 180 nodesToTrash input = map (\(PGS.Only a) -> a)
 181                         <$> runPGSQuery trashQuery (PGS.Only $ Values fields input)
 182   where
 183     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
 184     trashQuery :: PGS.Query
 185     trashQuery = [sql| UPDATE nodes_nodes as old SET
 186                  delete = new.delete
 187                  from (?) as new(node1_id,node2_id,delete)
 188                  WHERE old.node1_id = new.node1_id
 189                  AND   old.node2_id = new.node2_id
 190                  RETURNING new.node2_id
 191                   |]
 192
 193 -- | /!\ Really remove nodes in the Corpus or Annuaire
 194 emptyTrash :: CorpusId -> Cmd err [PGS.Only Int]
 195 emptyTrash cId = runPGSQuery delQuery (PGS.Only cId)
 196   where
 197     delQuery :: PGS.Query
 198     delQuery = [sql|DELETE from nodes_nodes n
 199                     WHERE n.node1_id = ?
 200                       AND n.delete = true
 201                     RETURNING n.node2_id
 202                 |]
 203 ------------------------------------------------------------------------