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 -- DocFacet
  57
  58 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
  59
  60 data Facet id created hyperdata favorite  = FacetDoc { facetDoc_id :: id
  61                                                        , facetDoc_created   :: created
  62                                                        , facetDoc_hyperdata :: hyperdata
  63                                                        , facetDoc_favorite  :: favorite
  64                                           -- To be added: Double
  65                                           --             , facetDoc_ngramCount :: ngramCount
  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 getDocFacet :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [FacetDoc]
  84 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
  85     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
  86
  87 selectDocFacet :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query FacetDocRead
  88 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
  89         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc facetDoc_created) $ selectDocFacet' parentId maybeNodeType
  90
  91
  92 -- | Left join to the favorites
  93 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
  94 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
  95     where
  96         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
  97
  98
  99 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 100                   -> Query (NodeRead, NodeNodeReadNull)
 101 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 102         where
 103             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 104                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 105                                                , ((.==) n1' n)
 106                                                ]
 107
 108 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 109 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 110         where
 111             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 112                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 113                                                , ((.==) (toNullable n1) n1')
 114                                                ]
 115
 116 -- | Left join to the ngram count per document
 117 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 118 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 119      where
 120         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 121
 122
 123 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 124                        -> Query (NodeRead, NodeNodeNgramReadNull)
 125 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 126      where
 127         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 128                  = (.&&) ((.==) n1 n1')
 129                          ((.==) nId' (toNullable n2))
 130
 131
 132
 133 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 134               Default NullMaker columnsR nullableColumnsR,
 135               Default Unpackspec columnsR columnsR,
 136               Default Unpackspec nullableColumnsR nullableColumnsR,
 137               Default Unpackspec columnsL1 columnsL1,
 138               Default Unpackspec columnsL columnsL) =>
 139               Query columnsL1 -> Query columnsR -> Query columnsL
 140                 -> ((columnsL1, columnsR) -> Column PGBool)
 141                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 142                 -> Query (columnsL, nullableColumnsR1)
 143 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 144
 145
 146 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 147 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 148     where
 149          cond12 (Node favId _ _ _ _ _ _, NodeNodeNgram favId' _ _ _)
 150                 = (.==) favId favId'
 151
 152          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 153          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 154                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 155
 156
 157 -- | Building the facet
 158 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 159 selectDocFacet' parentId _ = proc () -> do
 160     node <- (proc () -> do
 161
 162             -- Favorite Column
 163             (Node _ favTypeId _ favParentId _ _ _)      <- queryNodeTable -< ()
 164             restrict -< favTypeId .== 15 .&& favParentId .== (toNullable $ pgInt4 parentId)
 165
 166             -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
 167             -- Selecting the documents and joining Favorite Node
 168             (Node docId docTypeId _ docParentId _ created docHyperdata, NodeNode _ docTypeId' _) <- nodeNodeLeftJoin' (toNullable $ pgInt4 347537) -< ()
 169             restrict -< docParentId .== (toNullable $ pgInt4 parentId)
 170             let docTypeId'' = maybe 0 nodeTypeId (Just Document)
 171             restrict -< if docTypeId'' > 0
 172                            then docTypeId   .== (pgInt4 (docTypeId'' :: Int))
 173                            else (pgBool True)
 174
 175             -- Getting favorite data
 176             let isFav = ifThenElse (isNull docTypeId') (pgBool False) (pgBool True)
 177             -- Ngram count by document
 178             -- Counting the ngram
 179             -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
 180             -- restrict -< occId .== 347540
 181
 182             --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
 183             returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
 184     returnA -< node
 185
 186