src/Gargantext/Database/Facet.hs

   1 {-|
   2 Module      : Gargantext.Database.Facet
   3 Description : Main requests of Node to the database
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  13
  14 {-# LANGUAGE Arrows                      #-}
  15 {-# LANGUAGE DeriveGeneric               #-}
  16 {-# LANGUAGE TemplateHaskell             #-}
  17 {-# LANGUAGE FlexibleContexts            #-}
  18 {-# LANGUAGE FlexibleInstances           #-}
  19 {-# LANGUAGE MultiParamTypeClasses       #-}
  20 {-# LANGUAGE FunctionalDependencies      #-}
  21 {-# LANGUAGE NoMonomorphismRestriction   #-}
  22
  23 module Gargantext.Database.Facet where
  24
  25 import Prelude hiding (null, id, map, sum, not)
  26
  27 import Gargantext.Types
  28 import Gargantext.Types.Node (NodeType)
  29 import Gargantext.Database.NodeNode
  30 import Gargantext.Database.NodeNodeNgram
  31 import Gargantext.Database.Node
  32 import Gargantext.Database.Queries
  33 import Gargantext.Utils.Prefix (unPrefix)
  34 -- import Gargantext.Database.NodeNgram
  35
  36 -- import Data.Aeson (Value)
  37 import Data.Aeson.TH (deriveJSON)
  38 import Control.Arrow (returnA)
  39 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  40 import Data.Maybe (Maybe)
  41 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  42 import Data.Time (UTCTime)
  43 import Database.PostgreSQL.Simple (Connection)
  44 import Opaleye
  45 import Opaleye.Internal.Join (NullMaker)
  46
  47 import qualified Opaleye.Internal.Unpackspec()
  48 import Data.Profunctor.Product.Default (Default)
  49
  50 import Data.Time.Segment (jour)
  51
  52 import Test.QuickCheck.Arbitrary
  53 import Test.QuickCheck (elements)
  54
  55
  56
  57 ------------------------------------------------------------------------
  58 -- | DocFacet
  59 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
  60
  61 data Facet id created hyperdata favorite  =
  62      FacetDoc { facetDoc_id         :: id
  63               , facetDoc_created    :: created
  64               , facetDoc_hyperdata  :: hyperdata
  65               , facetDoc_favorite   :: favorite
  66               } deriving (Show)
  67 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  68
  69 instance Arbitrary FacetDoc where
  70     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav
  71                          | id'  <- [1..10]
  72                          , year <- [1990..2000]
  73                          , fav  <- [True, False]
  74                          , hp   <- hyperdataDocuments
  75                          ]
  76
  77 -- Facets / Views for the Front End
  78 type FacetDocRead  = Facet (Column PGInt4) (Column PGTimestamptz) (Column PGJsonb) (Column PGBool) -- (Column PGFloat8)
  79
  80 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
  81 $(makeLensesWith abbreviatedFields   ''Facet)
  82
  83 ------------------------------------------------------------------------
  84 type FacetDoc' = Facet' NodeId UTCTime HyperdataDocument Bool Int
  85
  86 data Facet' id created hyperdata favorite ngramCount =
  87      FacetDoc' { facetDocP_id         :: id
  88                , facetDocP_created    :: created
  89                , facetDocP_hyperdata  :: hyperdata
  90                , facetDocP_favorite   :: favorite
  91                , facetDocP_ngramCount :: ngramCount
  92                } deriving (Show)
  93 $(deriveJSON (unPrefix "facetDocP_") ''Facet')
  94
  95 instance Arbitrary FacetDoc' where
  96     arbitrary = elements [ FacetDoc' id' (jour year 01 01) hp fav ngramCount
  97                          | id'  <- [1..10]
  98                          , year <- [1990..2000]
  99                          , hp   <- hyperdataDocuments
 100                          , fav  <- [True, False]
 101                          , ngramCount <- [1..10]
 102                          ]
 103
 104 -- Facets / Views for the Front End
 105 type FacetDocRead'  = Facet' (Column PGInt4       )
 106                              (Column PGTimestamptz)
 107                              (Column PGJsonb      )
 108                              (Column PGBool       )
 109                              (Column PGInt4     )
 110
 111 $(makeAdaptorAndInstance "pFacetDocP" ''Facet')
 112 $(makeLensesWith abbreviatedFields    ''Facet')
 113
 114 ------------------------------------------------------------------------
 115
 116
 117 getDocFacet :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [FacetDoc]
 118 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
 119     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
 120
 121 selectDocFacet :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query FacetDocRead
 122 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
 123         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc facetDoc_created) $ selectDocFacet' parentId maybeNodeType
 124
 125
 126 -- | Left join to the favorites
 127 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 128 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 129     where
 130         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 131
 132
 133 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 134                   -> Query (NodeRead, NodeNodeReadNull)
 135 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 136         where
 137             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 138                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 139                                                , ((.==) n1' n)
 140                                                ]
 141
 142 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 143 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 144         where
 145             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 146                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 147                                                , ((.==) (toNullable n1) n1')
 148                                                ]
 149
 150 -- | Left join to the ngram count per document
 151 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 152 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 153      where
 154         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 155
 156
 157 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 158                        -> Query (NodeRead, NodeNodeNgramReadNull)
 159 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 160      where
 161         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 162                  = (.&&) ((.==) n1 n1')
 163                          ((.==) nId' (toNullable n2))
 164
 165
 166 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 167               Default NullMaker columnsR nullableColumnsR,
 168               Default Unpackspec columnsR columnsR,
 169               Default Unpackspec nullableColumnsR nullableColumnsR,
 170               Default Unpackspec columnsL1 columnsL1,
 171               Default Unpackspec columnsL columnsL) =>
 172               Query columnsL1 -> Query columnsR -> Query columnsL
 173                 -> ((columnsL1, columnsR) -> Column PGBool)
 174                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 175                 -> Query (columnsL, nullableColumnsR1)
 176 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 177
 178
 179 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 180 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 181     where
 182          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 183                 = (.==) occId occId'
 184
 185          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 186          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 187                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 188
 189
 190 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 191 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 192     where
 193          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 194                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 195
 196          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 197          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 198                 = ((.==) (nId) (nId'))
 199
 200
 201 getDocTest' :: Connection -> IO [FacetDoc']
 202 getDocTest' conn = runQuery conn selectDocFacet''
 203
 204 -- | Building the facet
 205 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 206 selectDocFacet'' :: Query FacetDocRead'
 207 selectDocFacet'' = proc () -> do
 208         (n1,(nn,n2)) <- leftJoin3''' -< ()
 209         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
 210                           (node_typename n1 .== (pgInt4 4))
 211
 212         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
 213                           (isNull $ node_typename n2)
 214
 215         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
 216                           (isNull $ node_parentId n2)
 217
 218         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 219 --
 220         returnA  -< FacetDoc' (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 237 selectDocFacet' parentId _ = proc () -> do
 238     node <- (proc () -> do
 239
 240             -- Favorite Column
 241             -- (Node docId docTypeId _ docParentId _ created docHyperdata, (Node _ favTypeId _ favParentId _ _ _, NodeNode _ docId' _))  <- leftJoin3'' -< ()
 242             (Node docId docTypeId _ docParentId _ created docHyperdata, (NodeNode _ docId' _, (Node _ favTypeId _ favParentId _ _ _)))  <- leftJoin3''' -< ()
 243
 244             restrict -< docTypeId .== (pgInt4 15) .&& docParentId .== (toNullable $ pgInt4 parentId)
 245
 246             -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
 247             -- Selecting the documents and joining Favorite Node
 248
 249             restrict -< favParentId .== (toNullable $ pgInt4 parentId) .&& favTypeId .== (toNullable 4)
 250
 251             -- let docTypeId'' = maybe 0 nodeTypeId (Just Document)
 252
 253             -- Getting favorite data
 254             let isFav = ifThenElse (isNull docId') (pgBool False) (pgBool True)
 255             -- Ngram count by document
 256             -- Counting the ngram
 257             -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
 258             -- restrict -< occId .== 347540
 259
 260             --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
 261             returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
 262     returnA -< node
 263