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