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